Ham Radio 2000/Ham Radio 2000.iso/ham2000/antenna/nec4pc/nec-2.for

Text File | 1994-10-17 | 303KB | 9,070 lines

C     PROGRAM NEC(INPUT,TAPE5=INPUT,OUTPUT,TAPE11,TAPE12,TAPE13,TAPE14,
C    1TAPE15,TAPE16,TAPE20,TAPE21)
C
C     NUMERICAL ELECTROMAGNETICS CODE (NEC2)  DEVELOPED AT LAWRENCE
C     LIVERMORE LAB., LIVERMORE, CA.  (CONTACT G. BURKE AT 415-422-8414
C     FOR PROBLEMS WITH THE NEC CODE.  FOR PROBLEMS WITH THE VAX IMPLEM-
C     ENTATION, CONTACT J. BREAKALL AT 415-422-8196 OR E. DOMNING AT 415
C     422-5936)
C     FILE CREATED 4/11/80.
C
C                ***********NOTICE**********
C     THIS COMPUTER CODE MATERIAL WAS PREPARED AS AN ACCOUNT OF WORK
C     SPONSORED BY THE UNITED STATES GOVERNMENT.  NEITHER THE UNITED
C     STATES NOR THE UNITED STATES DEPARTMENT OF ENERGY, NOR ANY OF
C     THEIR EMPLOYEES, NOR ANY OF THEIR CONTRACTORS, SUBCONTRACTORS, OR
C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR
C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY,
C     COMPLETENESS OR USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT
C     OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT
C     INFRINGE PRIVATELY-OWNED RIGHTS.
C
C***
C ***
C     DOUBLE PRECISION 6/4/85
C
C ***
      IMPLICIT REAL (A-H,O-Z)
      CHARACTER   AIN*2, ATST*2, INFILE*80, OTFILE*80
C***
      PARAMETER ( NM=600, N2M=800, N3M=1000)
C     INTEGER  AIN,ATST,PNET,HPOL
      REALHPOL,PNET
      COMPLEX  CM, FJ, VSANT, ETH, EPH, ZRATI, CUR, CURI, ZARRAY,
     &ZRATI2
      COMPLEX  EX, EY, EZ, ZPED, VQD, VQDS, T1, Y11A, Y12A, EPSC, U,
     & U2, XX1, XX2
      COMPLEX  AR1, AR2, AR3, EPSCF, FRATI
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /CMB/ CM(90000)
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      COMMON  /SAVE/ IP( N2M), KCOM, COM(19,5), EPSR, SIG, SCRWLT,
     &SCRWRT, FMHZ
      COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
     &CII( NM), CUR( N3M)
      COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
     &KSYMP, IFAR, IPERF, T1, T2
      COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
      COMMON  /YPARM/ NCOUP, ICOUP, NCTAG(5), NCSEG(5), Y11A(5), Y12A(
     &20)
      COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
     &NSCON, IPCON(10), NPCON
      COMMON  /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
     &, IQDS(30), NVQD, NSANT, NQDS
      COMMON  /NETCX/ ZPED, PIN, PNLS, NEQ, NPEQ, NEQ2, NONET, NTSOL,
     &NPRINT, MASYM, ISEG1(150), ISEG2(150), X11R(150), X11I(150),
     &X12R(150), X12I(150), X22R(150), X22I(150), NTYP(150)
      COMMON  /FPAT/ NTH, NPH, IPD, IAVP, INOR, IAX, THETS, PHIS, DTH,
     &DPH, RFLD, GNOR, CLT, CHT, EPSR2, SIG2, IXTYP, XPR6, PINR, PNLR,
     &PLOSS, NEAR, NFEH, NRX, NRY, NRZ, XNR, YNR, ZNR, DXNR, DYNR, DZNR
     &
      COMMON  /GGRID/ AR1(11,10,4), AR2(17,5,4), AR3(9,8,4), EPSCF, DXA
     &(3), DYA(3), XSA(3), YSA(3), NXA(3), NYA(3)
C***
      COMMON  /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH
C***
      COMMON  /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4
      DIMENSION  CAB(1), SAB(1), X2(1), Y2(1), Z2(1)
      DIMENSION  LDTYP(200), LDTAG(200), LDTAGF(200), LDTAGT(200),
     & ZLR(200), ZLI(200), ZLC(200)
      DIMENSION  ATST(22), PNET(6), HPOL(3), IX( N2M)
      DIMENSION  FNORM(200)
C***
      DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
      DIMENSION  XTEMP( NM), YTEMP( NM), ZTEMP( NM), SITEMP( NM),
     &BITEMP( NM)
      EQUIVALENCE(CAB,ALP),(SAB,BET),(X2,SI),(Y2,ALP),(Z2,BET)
      EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
     &T2Z,ITAG)
      DATA   ATST/'CE','FR','LD','GN','EX','NT','XQ','NE','GD','RP',
     &'CM','NX','EN','TL','PT','KH','NH','PQ','EK','WG','CP','PL'/
      DATA   HPOL/6HLINEAR,5HRIGHT,4HLEFT/
      DATA   PNET/6H      ,2H  ,6HSTRAIG,2HHT,6HCROSSE,1HD/
      DATA   TA/1.745329252D-02/, CVEL/299.8/
C***
      DATA   LOADMX, NSMAX, NETMX/200,150,150/, NORMF/200/
  706 CONTINUE
      PRINT700
  700 FORMAT('$ENTER DATA INPUT FILENAME [HIT RETURN FOR TERMINAL',
     &' INPUT] : ',/,'$     >')
  701 FORMAT(A)
      READ( *,701,ERR=702)  INFILE
      CALL STR0PC( INFILE, INFILE)
C      OPEN (UNIT=5,FILE=INFILE,STATUS='OLD',READONLY,ERR=702)
      IF( INFILE.NE.' ') THEN
      OPEN ( UNIT=5,FILE=INFILE,STATUS='OLD',ERR=702)
      ENDIF
  707 CONTINUE
      PRINT703
  703 FORMAT('$ENTER DATA OUTPUT FILENAME [HIT RETURN FOR TERMINAL',
     &' OUTPUT] : ',/,'$     >')
      READ( *,701,ERR=704)  OTFILE
      CALL STR0PC( OTFILE, OTFILE)
      IF( OTFILE.NE.' ') THEN
      OPEN ( UNIT=6,FILE=OTFILE,STATUS='NEW',ERR=704)
      ENDIF
      GOTO 705
  702 CALL ERROR
      GOTO 706
  704 CALL ERROR
      GOTO 707
C***
  705 CONTINUE
      CALL SECNDS(EXTIM)
      FJ=(0.,1.)
      LD=600
      NXA(1)=0
      IRESRV=90000
C***
    1 KCOM=0
      IFRTMW=0
C***
      IFRTMP=0
    2 KCOM= KCOM+1
      IF( KCOM.GT.5) KCOM=5
C***
      READ( 5,125)  AIN,( COM( I, KCOM), I=1,19)
C***
      CALL STR0PC( AIN, AIN)
      IF( KCOM.GT.1) GOTO 3
      WRITE( 6,126)
      WRITE( 6,127)
      WRITE( 6,128)
    3 WRITE( 6,129) ( COM( I, KCOM), I=1,19)
      IF( AIN.EQ. ATST(11)) GOTO 2
      IF( AIN.EQ. ATST(1)) GOTO 4
      WRITE( 6,130)
      STOP
    4 CONTINUE
      DO 5  I=1, LD
    5 ZARRAY( I)=(0.,0.)
      MPCNT=0
C
C     SET UP GEOMETRY DATA IN SUBROUTINE DATAGN
C
      IMAT=0
      CALL DATAGN
      IFLOW=1
C
C     CORE ALLOCATION FOR ARRAYS B, C, AND D FOR N.G.F. SOLUTION
C
      IF( IMAT.EQ.0) GOTO 326
      NEQ= N1+2* M1
      NEQ2= N- N1+2*( M- M1)+ NSCON+2* NPCON
      CALL FBNGF( NEQ, NEQ2, IRESRV, IB11, IC11, ID11, IX11)
      GOTO 6
  326 NEQ= N+2* M
      NEQ2=0
      IB11=1
      IC11=1
      ID11=1
      IX11=1
      ICASX=0
    6 NPEQ= NP+2* MP
C
C     DEFAULT VALUES FOR INPUT PARAMETERS AND FLAGS
C
C***
      WRITE( 6,135)
      IPLP1=0
      IPLP2=0
      IPLP3=0
C***
      IPLP4=0
      IGO=1
      FMHZS= CVEL
      NFRQ=1
      RKH=1.
      IEXK=0
      IXTYP=0
      NLOAD=0
      NONET=0
      NEAR=-1
      IPTFLG=-2
      IPTFLQ=-1
      IFAR=-1
      ZRATI=(1.,0.)
      IPED=0
      IRNGF=0
      NCOUP=0
      ICOUP=0
      IF( ICASX.GT.0) GOTO 14
      FMHZ= CVEL
      NLODF=0
      KSYMP=1
      NRADL=0
C
C     MAIN INPUT SECTION - STANDARD READ STATEMENT - JUMPS TO APPRO-
C     PRIATE SECTION FOR SPECIFIC PARAMETER SET UP
C
C14    READ(5,136)AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,TMP4,TMP5,
C     1TMP6
C***
      IPERF=0
C***
   14 CALL READMN( AIN, ITMP1, ITMP2, ITMP3, ITMP4, TMP1, TMP2, TMP3,
     &TMP4, TMP5, TMP6)
      MPCNT= MPCNT+1
      WRITE( 6,137)  MPCNT, AIN, ITMP1, ITMP2, ITMP3, ITMP4, TMP1, TMP2
     &, TMP3, TMP4, TMP5, TMP6
      IF( AIN.EQ. ATST(2)) GOTO 16
      IF( AIN.EQ. ATST(3)) GOTO 17
      IF( AIN.EQ. ATST(4)) GOTO 21
      IF( AIN.EQ. ATST(5)) GOTO 24
      IF( AIN.EQ. ATST(6)) GOTO 28
      IF( AIN.EQ. ATST(14)) GOTO 28
      IF( AIN.EQ. ATST(15)) GOTO 31
      IF( AIN.EQ. ATST(18)) GOTO 319
      IF( AIN.EQ. ATST(7)) GOTO 37
      IF( AIN.EQ. ATST(8)) GOTO 32
      IF( AIN.EQ. ATST(17)) GOTO 208
      IF( AIN.EQ. ATST(9)) GOTO 34
      IF( AIN.EQ. ATST(10)) GOTO 36
      IF( AIN.EQ. ATST(16)) GOTO 305
      IF( AIN.EQ. ATST(19)) GOTO 320
      IF( AIN.EQ. ATST(12)) GOTO 1
      IF( AIN.EQ. ATST(20)) GOTO 322
C***
      IF( AIN.EQ. ATST(21)) GOTO 304
C***
      IF( AIN.EQ. ATST(22)) GOTO 330
      IF( AIN.NE. ATST(13)) GOTO 15
      CALL SECNDS( TMP1)
      TMP1= TMP1- EXTIM
      WRITE( 6,201)  TMP1
      STOP
   15 WRITE( 6,138)
C
C     FREQUENCY PARAMETERS
C
      STOP
   16 IFRQ= ITMP1
      IF( ICASX.EQ.0) GOTO 8
      WRITE( 6,303)  AIN
      STOP
    8 NFRQ= ITMP2
      IF( NFRQ.EQ.0) NFRQ=1
      FMHZ= TMP1
      DELFRQ= TMP2
      IF( IPED.EQ.1) ZPNORM=0.
      IGO=1
      IFLOW=1
C
C     MATRIX INTEGRATION LIMIT
C
      GOTO 14
  305 RKH= TMP1
      IF( IGO.GT.2) IGO=2
      IFLOW=1
C
C     EXTENDED THIN WIRE KERNEL OPTION
C
      GOTO 14
  320 IEXK=1
      IF( ITMP1.EQ.-1) IEXK=0
      IF( IGO.GT.2) IGO=2
      IFLOW=1
C
C     MAXIMUM COUPLING BETWEEN ANTENNAS
C
      GOTO 14
  304 IF( IFLOW.NE.2) NCOUP=0
      ICOUP=0
      IFLOW=2
      IF( ITMP2.EQ.0) GOTO 14
      NCOUP= NCOUP+1
      IF( NCOUP.GT.5) GOTO 312
      NCTAG( NCOUP)= ITMP1
      NCSEG( NCOUP)= ITMP2
      IF( ITMP4.EQ.0) GOTO 14
      NCOUP= NCOUP+1
      IF( NCOUP.GT.5) GOTO 312
      NCTAG( NCOUP)= ITMP3
      NCSEG( NCOUP)= ITMP4
      GOTO 14
  312 WRITE( 6,313)
C
C     LOADING PARAMETERS
C
      STOP
   17 IF( IFLOW.EQ.3) GOTO 18
      NLOAD=0
      IFLOW=3
      IF( IGO.GT.2) IGO=2
      IF( ITMP1.EQ.(-1)) GOTO 14
   18 NLOAD= NLOAD+1
      IF( NLOAD.LE. LOADMX) GOTO 19
      WRITE( 6,139)
      STOP
   19 LDTYP( NLOAD)= ITMP1
      LDTAG( NLOAD)= ITMP2
      IF( ITMP4.EQ.0) ITMP4= ITMP3
      LDTAGF( NLOAD)= ITMP3
      LDTAGT( NLOAD)= ITMP4
      IF( ITMP4.GE. ITMP3) GOTO 20
      WRITE( 6,140)  NLOAD, ITMP3, ITMP4
      STOP
   20 ZLR( NLOAD)= TMP1
      ZLI( NLOAD)= TMP2
      ZLC( NLOAD)= TMP3
C
C     GROUND PARAMETERS UNDER THE ANTENNA
C
      GOTO 14
   21 IFLOW=4
      IF( ICASX.EQ.0) GOTO 10
      WRITE( 6,303)  AIN
      STOP
   10 IF( IGO.GT.2) IGO=2
      IF( ITMP1.NE.(-1)) GOTO 22
      KSYMP=1
      NRADL=0
      IPERF=0
      GOTO 14
   22 IPERF= ITMP1
      NRADL= ITMP2
      KSYMP=2
      EPSR= TMP1
      SIG= TMP2
      IF( NRADL.EQ.0) GOTO 23
      IF( IPERF.NE.2) GOTO 314
      WRITE( 6,390)
      STOP
  314 SCRWLT= TMP3
      SCRWRT= TMP4
      GOTO 14
   23 EPSR2= TMP3
      SIG2= TMP4
      CLT= TMP5
      CHT= TMP6
C
C     EXCITATION PARAMETERS
C
      GOTO 14
   24 IF( IFLOW.EQ.5) GOTO 25
      NSANT=0
      NVQD=0
      IPED=0
      IFLOW=5
      IF( IGO.GT.3) IGO=3
   25 MASYM= ITMP4/10
      IF( ITMP1.GT.0.AND. ITMP1.NE.5) GOTO 27
      IXTYP= ITMP1
      NTSOL=0
      IF( IXTYP.EQ.0) GOTO 205
      NVQD= NVQD+1
      IF( NVQD.GT. NSMAX) GOTO 206
      IVQD( NVQD)= ISEGNO( ITMP2, ITMP3)
      VQD( NVQD)= CMPLX( TMP1, TMP2)
      IF( ABS( VQD( NVQD)).LT.1.D-20) VQD( NVQD)=(1.,0.)
      GOTO 207
  205 NSANT= NSANT+1
      IF( NSANT.LE. NSMAX) GOTO 26
  206 WRITE( 6,141)
      STOP
   26 ISANT( NSANT)= ISEGNO( ITMP2, ITMP3)
      VSANT( NSANT)= CMPLX( TMP1, TMP2)
      IF( ABS( VSANT( NSANT)).LT.1.D-20) VSANT( NSANT)=(1.,0.)
  207 IPED= ITMP4- MASYM*10
      ZPNORM= TMP3
      IF( IPED.EQ.1.AND. ZPNORM.GT.0) IPED=2
      GOTO 14
   27 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) NTSOL=0
      IXTYP= ITMP1
      NTHI= ITMP2
      NPHI= ITMP3
      XPR1= TMP1
      XPR2= TMP2
      XPR3= TMP3
      XPR4= TMP4
      XPR5= TMP5
      XPR6= TMP6
      NSANT=0
      NVQD=0
      THETIS= XPR1
      PHISS= XPR2
C
C     NETWORK PARAMETERS
C
      GOTO 14
   28 IF( IFLOW.EQ.6) GOTO 29
      NONET=0
      NTSOL=0
      IFLOW=6
      IF( IGO.GT.3) IGO=3
      IF( ITMP2.EQ.(-1)) GOTO 14
   29 NONET= NONET+1
      IF( NONET.LE. NETMX) GOTO 30
      WRITE( 6,142)
      STOP
   30 NTYP( NONET)=2
      IF( AIN.EQ. ATST(6)) NTYP( NONET)=1
      ISEG1( NONET)= ISEGNO( ITMP1, ITMP2)
      ISEG2( NONET)= ISEGNO( ITMP3, ITMP4)
      X11R( NONET)= TMP1
      X11I( NONET)= TMP2
      X12R( NONET)= TMP3
      X12I( NONET)= TMP4
      X22R( NONET)= TMP5
      X22I( NONET)= TMP6
      IF( NTYP( NONET).EQ.1.OR. TMP1.GT.0.) GOTO 14
      NTYP( NONET)=3
C***
C
C     PLOT FLAGS
C
      X11R( NONET)=- TMP1
  330 IPLP1= ITMP1
      IPLP2= ITMP2
      IPLP3= ITMP3
C***
      IPLP4= ITMP4
C
C     PRINT CONTROL FOR CURRENT
C
      GOTO 14
   31 IPTFLG= ITMP1
      IPTAG= ITMP2
      IPTAGF= ITMP3
      IPTAGT= ITMP4
      IF( ITMP3.EQ.0.AND. IPTFLG.NE.-1) IPTFLG=-2
      IF( ITMP4.EQ.0) IPTAGT= IPTAGF
C
C     WRITE CONTROL FOR CHARGE
C
      GOTO 14
  319 IPTFLQ= ITMP1
      IPTAQ= ITMP2
      IPTAQF= ITMP3
      IPTAQT= ITMP4
      IF( ITMP3.EQ.0.AND. IPTFLQ.NE.-1) IPTFLQ=-2
      IF( ITMP4.EQ.0) IPTAQT= IPTAQF
C
C     NEAR FIELD CALCULATION PARAMETERS
C
      GOTO 14
  208 NFEH=1
      GOTO 209
   32 NFEH=0
  209 IF(.NOT.( IFLOW.EQ.8.AND. NFRQ.NE.1)) GOTO 33
      WRITE( 6,143)
   33 NEAR= ITMP1
      NRX= ITMP2
      NRY= ITMP3
      NRZ= ITMP4
      XNR= TMP1
      YNR= TMP2
      ZNR= TMP3
      DXNR= TMP4
      DYNR= TMP5
      DZNR= TMP6
      IFLOW=8
      IF( NFRQ.NE.1) GOTO 14
C
C     GROUND REPRESENTATION
C
      GOTO (41,46,53,71,72), IGO
   34 EPSR2= TMP1
      SIG2= TMP2
      CLT= TMP3
      CHT= TMP4
      IFLOW=9
C
C     STANDARD OBSERVATION ANGLE PARAMETERS
C
      GOTO 14
   36 IFAR= ITMP1
      NTH= ITMP2
      NPH= ITMP3
      IF( NTH.EQ.0) NTH=1
      IF( NPH.EQ.0) NPH=1
      IPD= ITMP4/10
      IAVP= ITMP4- IPD*10
      INOR= IPD/10
      IPD= IPD- INOR*10
      IAX= INOR/10
      INOR= INOR- IAX*10
      IF( IAX.NE.0) IAX=1
      IF( IPD.NE.0) IPD=1
      IF( NTH.LT.2.OR. NPH.LT.2) IAVP=0
      IF( IFAR.EQ.1) IAVP=0
      THETS= TMP1
      PHIS= TMP2
      DTH= TMP3
      DPH= TMP4
      RFLD= TMP5
      GNOR= TMP6
      IFLOW=10
C
C     WRITE NUMERICAL GREEN'S FUNCTION TAPE
C
      GOTO (41,46,53,71,78), IGO
  322 IFLOW=12
      IF( ICASX.EQ.0) GOTO 301
      WRITE( 6,302)
      STOP
  301 IRNGF= IRESRV/2
C
C     EXECUTE CARD  -  CALC. INCLUDING RADIATED FIELDS
C
      GOTO (41,46,52,52,52), IGO
   37 IF( IFLOW.EQ.10.AND. ITMP1.EQ.0) GOTO 14
      IF( NFRQ.EQ.1.AND. ITMP1.EQ.0.AND. IFLOW.GT.7) GOTO 14
      IF( ITMP1.NE.0) GOTO 39
      IF( IFLOW.GT.7) GOTO 38
      IFLOW=7
      GOTO 40
   38 IFLOW=11
      GOTO 40
   39 IFAR=0
      RFLD=0.
      IPD=0
      IAVP=0
      INOR=0
      IAX=0
      NTH=91
      NPH=1
      THETS=0.
      PHIS=0.
      DTH=1.0
      DPH=0.
      IF( ITMP1.EQ.2) PHIS=90.
      IF( ITMP1.NE.3) GOTO 40
      NPH=2
      DPH=90.
C
C     END OF THE MAIN INPUT SECTION
C
C     BEGINNING OF THE FREQUENCY DO LOOP
C
   40 GOTO (41,46,53,71,78), IGO
C***
   41 MHZ=1
      IF( N.EQ.0.OR. IFRTMW.EQ.1) GOTO 406
      IFRTMW=1
      DO 445  I=1, N
      XTEMP( I)= X( I)
      YTEMP( I)= Y( I)
      ZTEMP( I)= Z( I)
      SITEMP( I)= SI( I)
      BITEMP( I)= BI( I)
  445 CONTINUE
  406 IF( M.EQ.0.OR. IFRTMP.EQ.1) GOTO 407
      IFRTMP=1
      J= LD+1
      DO 545  I=1, M
      J= J-1
      XTEMP( J)= X( J)
      YTEMP( J)= Y( J)
      ZTEMP( J)= Z( J)
      BITEMP( J)= BI( J)
  545 CONTINUE
  407 CONTINUE
C***
C     CORE ALLOCATION FOR PRIMARY INTERACTON MATRIX.  (A)
      FMHZ1= FMHZ
      IF( IMAT.EQ.0) CALL FBLOCK( NPEQ, NEQ, IRESRV, IRNGF, IPSYM)
   42 IF( MHZ.EQ.1) GOTO 44
C      FMHZ=FMHZ+DELFRQ
C***
      IF( IFRQ.EQ.1) GOTO 43
      FMHZ= FMHZ1+( MHZ-1)* DELFRQ
      GOTO 44
   43 FMHZ= FMHZ* DELFRQ
C***
   44 FR= FMHZ/ CVEL
      WLAM= CVEL/ FMHZ
      WRITE( 6,145)  FMHZ, WLAM
      WRITE( 6,196)  RKH
C     FREQUENCY SCALING OF GEOMETRIC PARAMETERS
C***      FMHZS=FMHZ
      IF( IEXK.EQ.1) WRITE( 6,321)
      IF( N.EQ.0) GOTO 306
C***
      DO 45  I=1, N
      X( I)= XTEMP( I)* FR
      Y( I)= YTEMP( I)* FR
      Z( I)= ZTEMP( I)* FR
      SI( I)= SITEMP( I)* FR
C***
   45 BI( I)= BITEMP( I)* FR
  306 IF( M.EQ.0) GOTO 307
      FR2= FR* FR
      J= LD+1
      DO 245  I=1, M
C***
      J= J-1
      X( J)= XTEMP( J)* FR
      Y( J)= YTEMP( J)* FR
      Z( J)= ZTEMP( J)* FR
C***
  245 BI( J)= BITEMP( J)* FR2
C     STRUCTURE SEGMENT LOADING
  307 IGO=2
   46 WRITE( 6,146)
      IF( NLOAD.NE.0) CALL LOAD( LDTYP, LDTAG, LDTAGF, LDTAGT, ZLR, ZLI
     &, ZLC)
      IF( NLOAD.EQ.0.AND. NLODF.EQ.0) WRITE( 6,147)
C     GROUND PARAMETER
      IF( NLOAD.EQ.0.AND. NLODF.NE.0) WRITE( 6,327)
      WRITE( 6,148)
      IF( KSYMP.EQ.1) GOTO 49
      FRATI=(1.,0.)
      IF( IPERF.EQ.1) GOTO 48
      IF( SIG.LT.0.) SIG=- SIG/(59.96* WLAM)
      EPSC= CMPLX( EPSR,- SIG* WLAM*59.96)
      ZRATI=1./ SQRT( EPSC)
      U= ZRATI
      U2= U* U
      IF( NRADL.EQ.0) GOTO 47
      SCRWL= SCRWLT/ WLAM
      SCRWR= SCRWRT/ WLAM
      T1= FJ*2367.067D+0/ DFLOAT( NRADL)
      T2= SCRWR* DFLOAT( NRADL)
      WRITE( 6,170)  NRADL, SCRWLT, SCRWRT
      WRITE( 6,149)
   47 IF( IPERF.EQ.2) GOTO 328
      WRITE( 6,391)
      GOTO 329
  328 IF( NXA(1).EQ.0) READ( 21)  AR1, AR2, AR3, EPSCF, DXA, DYA, XSA,
     &YSA, NXA, NYA
      FRATI=( EPSC-1.)/( EPSC+1.)
      IF( ABS(( EPSCF- EPSC)/ EPSC).LT.1.D-3) GOTO 400
      WRITE( 6,393)  EPSCF, EPSC
      STOP
  400 WRITE( 6,392)
  329 WRITE( 6,150)  EPSR, SIG, EPSC
      GOTO 50
   48 WRITE( 6,151)
      GOTO 50
   49 WRITE( 6,152)
C * * *
C     FILL AND FACTOR PRIMARY INTERACTION MATRIX
C
   50 CONTINUE
      CALL SECNDS( TIM1)
      IF( ICASX.NE.0) GOTO 324
      CALL CMSET( NEQ, CM, RKH, IEXK)
      CALL SECNDS( TIM2)
      TIM= TIM2- TIM1
      CALL FACTRS( NPEQ, NEQ, CM, IP, IX,11,12,13,14)
C
C     N.G.F. - FILL B, C, AND D AND FACTOR D-C(INV(A)B)
C
C ****
      GOTO 323
C ****
  324 IF( NEQ2.EQ.0) GOTO 333
      CALL CMNGF( CM( IB11), CM( IC11), CM( ID11), NPBX, NEQ, NEQ2, RKH
     &, IEXK)
      CALL SECNDS( TIM2)
      TIM= TIM2- TIM1
      CALL FACGF( CM, CM( IB11), CM( IC11), CM( ID11), CM( IX11), IP,
     &IX, NP, N1, MP, M1, NEQ, NEQ2)
  323 CALL SECNDS( TIM1)
      TIM2= TIM1- TIM2
      WRITE( 6,153)  TIM, TIM2
  333 IGO=3
      NTSOL=0
C     WRITE N.G.F. FILE
      IF( IFLOW.NE.12) GOTO 53
   52 CALL GFOUT
C
C     EXCITATION SET UP (RIGHT HAND SIDE, -E INC.)
C
      GOTO 14
   53 NTHIC=1
      NPHIC=1
      INC=1
      NPRINT=0
   54 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) GOTO 56
      IF( IPTFLG.LE.0.OR. IXTYP.EQ.4) WRITE( 6,154)
      TMP5= TA* XPR5
      TMP4= TA* XPR4
      IF( IXTYP.NE.4) GOTO 55
      TMP1= XPR1/ WLAM
      TMP2= XPR2/ WLAM
      TMP3= XPR3/ WLAM
      TMP6= XPR6/( WLAM* WLAM)
      WRITE( 6,156)  XPR1, XPR2, XPR3, XPR4, XPR5, XPR6
      GOTO 56
   55 TMP1= TA* XPR1
      TMP2= TA* XPR2
      TMP3= TA* XPR3
      TMP6= XPR6
      IF( IPTFLG.LE.0) WRITE( 6,155)  XPR1, XPR2, XPR3, HPOL( IXTYP),
     &XPR6
C
C     MATRIX SOLVING  (NETWK CALLS SOLVES)
C
   56 CALL ETMNS( TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, IXTYP, CUR)
      IF( NONET.EQ.0.OR. INC.GT.1) GOTO 60
      WRITE( 6,158)
      ITMP3=0
      ITMP1= NTYP(1)
      DO 59  I=1,2
      IF( ITMP1.EQ.3) ITMP1=2
      IF( ITMP1.EQ.2) WRITE( 6,159)
      IF( ITMP1.EQ.1) WRITE( 6,160)
      DO 58  J=1, NONET
      ITMP2= NTYP( J)
      IF(( ITMP2/ ITMP1).EQ.1) GOTO 57
      ITMP3= ITMP2
      GOTO 58
   57 ITMP4= ISEG1( J)
      ITMP5= ISEG2( J)
      IF( ITMP2.GE.2.AND. X11I( J).LE.0.) X11I( J)= WLAM* SQRT(( X(
     &ITMP5)- X( ITMP4))**2+( Y( ITMP5)- Y( ITMP4))**2+( Z( ITMP5)- Z(
     &ITMP4))**2)
      WRITE( 6,157)  ITAG( ITMP4), ITMP4, ITAG( ITMP5), ITMP5, X11R( J)
     &, X11I( J), X12R( J), X12I( J), X22R( J), X22I( J), PNET(2* ITMP2
     &-1), PNET(2* ITMP2)
   58 CONTINUE
      IF( ITMP3.EQ.0) GOTO 60
      ITMP1= ITMP3
   59 CONTINUE
   60 CONTINUE
      IF( INC.GT.1.AND. IPTFLG.GT.0) NPRINT=1
      CALL NETWK( CM, CM( IB11), CM( IC11), CM( ID11), IP, CUR)
      NTSOL=1
      IF( IPED.EQ.0) GOTO 61
      ITMP1= MHZ+4*( MHZ-1)
      IF( ITMP1.GT.( NORMF-3)) GOTO 61
      FNORM( ITMP1)= REAL( ZPED)
      FNORM( ITMP1+1)= AIMAG( ZPED)
      FNORM( ITMP1+2)= ABS( ZPED)
      FNORM( ITMP1+3)= CANG( ZPED)
      IF( IPED.EQ.2) GOTO 61
      IF( FNORM( ITMP1+2).GT. ZPNORM) ZPNORM= FNORM( ITMP1+2)
C
C     PRINTING STRUCTURE CURRENTS
C
   61 CONTINUE
      IF( N.EQ.0) GOTO 308
      IF( IPTFLG.EQ.(-1)) GOTO 63
      IF( IPTFLG.GT.0) GOTO 62
      WRITE( 6,161)
      WRITE( 6,162)
      GOTO 63
   62 IF( IPTFLG.EQ.3.OR. INC.GT.1) GOTO 63
      WRITE( 6,163)  XPR3, HPOL( IXTYP), XPR6
   63 PLOSS=0.
      ITMP1=0
      JUMP= IPTFLG+1
      DO 69  I=1, N
      CURI= CUR( I)* WLAM
      CMAG= ABS( CURI)
      PH= CANG( CURI)
      IF( NLOAD.EQ.0.AND. NLODF.EQ.0) GOTO 64
      IF( ABS( REAL( ZARRAY( I))).LT.1.D-20) GOTO 64
      PLOSS= PLOSS+.5* CMAG* CMAG* REAL( ZARRAY( I))* SI( I)
   64 IF( JUMP) 68,69,65
   65 IF( IPTAG.EQ.0) GOTO 66
      IF( ITAG( I).NE. IPTAG) GOTO 69
   66 ITMP1= ITMP1+1
      IF( ITMP1.LT. IPTAGF.OR. ITMP1.GT. IPTAGT) GOTO 69
      IF( IPTFLG.EQ.0) GOTO 68
      IF( IPTFLG.LT.2.OR. INC.GT. NORMF) GOTO 67
      FNORM( INC)= CMAG
      ISAVE= I
   67 IF( IPTFLG.NE.3) WRITE( 6,164)  XPR1, XPR2, CMAG, PH, I
      GOTO 69
C***
   68 WRITE( 6,165)  I, ITAG( I), X( I), Y( I), Z( I), SI( I), CURI,
     &CMAG, PH
      IF( IPLP1.NE.1) GOTO 69
      IF( IPLP2.EQ.1) WRITE( 8,*)  CURI
C***
      IF( IPLP2.EQ.2) WRITE( 8,*)  CMAG, PH
   69 CONTINUE
      IF( IPTFLQ.EQ.(-1)) GOTO 308
      WRITE( 6,315)
      ITMP1=0
      FR=1.D-6/ FMHZ
      DO 316  I=1, N
      IF( IPTFLQ.EQ.(-2)) GOTO 318
      IF( IPTAQ.EQ.0) GOTO 317
      IF( ITAG( I).NE. IPTAQ) GOTO 316
  317 ITMP1= ITMP1+1
      IF( ITMP1.LT. IPTAQF.OR. ITMP1.GT. IPTAQT) GOTO 316
  318 CURI= FR* CMPLX(- BII( I), BIR( I))
      CMAG= ABS( CURI)
      PH= CANG( CURI)
      WRITE( 6,165)  I, ITAG( I), X( I), Y( I), Z( I), SI( I), CURI,
     &CMAG, PH
  316 CONTINUE
  308 IF( M.EQ.0) GOTO 310
      WRITE( 6,197)
      J= N-2
      ITMP1= LD+1
      DO 309  I=1, M
      J= J+3
      ITMP1= ITMP1-1
      EX= CUR( J)
      EY= CUR( J+1)
      EZ= CUR( J+2)
      ETH= EX* T1X( ITMP1)+ EY* T1Y( ITMP1)+ EZ* T1Z( ITMP1)
      EPH= EX* T2X( ITMP1)+ EY* T2Y( ITMP1)+ EZ* T2Z( ITMP1)
      ETHM= ABS( ETH)
      ETHA= CANG( ETH)
      EPHM= ABS( EPH)
C309   WRITE(6,198) I,X(ITMP1),Y(ITMP1),Z(ITMP1),ETHM,ETHA,EPHM,EPHA,E
C     1X,EY, EZ
C***
      EPHA= CANG( EPH)
      WRITE( 6,198)  I, X( ITMP1), Y( ITMP1), Z( ITMP1), ETHM, ETHA,
     &EPHM, EPHA, EX, EY, EZ
      IF( IPLP1.NE.1) GOTO 309
      IF( IPLP3.EQ.1) WRITE( 8,*)  EX
      IF( IPLP3.EQ.2) WRITE( 8,*)  EY
      IF( IPLP3.EQ.3) WRITE( 8,*)  EZ
      IF( IPLP3.EQ.4) WRITE( 8,*)  EX, EY, EZ
C***
  309 CONTINUE
  310 IF( IXTYP.NE.0.AND. IXTYP.NE.5) GOTO 70
      TMP1= PIN- PNLS- PLOSS
      TMP2=100.* TMP1/ PIN
      WRITE( 6,166)  PIN, TMP1, PLOSS, PNLS, TMP2
   70 CONTINUE
      IGO=4
      IF( NCOUP.GT.0) CALL COUPLE( CUR, WLAM)
      IF( IFLOW.NE.7) GOTO 71
      IF( IXTYP.GT.0.AND. IXTYP.LT.4) GOTO 113
      IF( NFRQ.NE.1) GOTO 120
      WRITE( 6,135)
      GOTO 14
C
C     NEAR FIELD CALCULATION
C
   71 IGO=5
   72 IF( NEAR.EQ.(-1)) GOTO 78
      CALL NFPAT
      IF( MHZ.EQ. NFRQ) NEAR=-1
      IF( NFRQ.NE.1) GOTO 78
      WRITE( 6,135)
C
C     STANDARD FAR FIELD CALCULATION
C
      GOTO 14
   78 IF( IFAR.EQ.-1) GOTO 113
      PINR= PIN
      PNLR= PNLS
      CALL RDPAT
  113 IF( IXTYP.EQ.0.OR. IXTYP.GE.4) GOTO 119
      NTHIC= NTHIC+1
      INC= INC+1
      XPR1= XPR1+ XPR4
      IF( NTHIC.LE. NTHI) GOTO 54
      NTHIC=1
      XPR1= THETIS
      XPR2= XPR2+ XPR5
      NPHIC= NPHIC+1
      IF( NPHIC.LE. NPHI) GOTO 54
      NPHIC=1
      XPR2= PHISS
C     NORMALIZED RECEIVING PATTERN PRINTED
      IF( IPTFLG.LT.2) GOTO 119
      ITMP1= NTHI* NPHI
      IF( ITMP1.LE. NORMF) GOTO 114
      ITMP1= NORMF
      WRITE( 6,181)
  114 TMP1= FNORM(1)
      DO 115  J=2, ITMP1
      IF( FNORM( J).GT. TMP1) TMP1= FNORM( J)
  115 CONTINUE
      WRITE( 6,182)  TMP1, XPR3, HPOL( IXTYP), XPR6, ISAVE
      DO 118  J=1, NPHI
      ITMP2= NTHI*( J-1)
      DO 116  I=1, NTHI
      ITMP3= I+ ITMP2
      IF( ITMP3.GT. ITMP1) GOTO 117
      TMP2= FNORM( ITMP3)/ TMP1
      TMP3= DB20( TMP2)
      WRITE( 6,183)  XPR1, XPR2, TMP3, TMP2
      XPR1= XPR1+ XPR4
  116 CONTINUE
  117 XPR1= THETIS
      XPR2= XPR2+ XPR5
  118 CONTINUE
      XPR2= PHISS
  119 IF( MHZ.EQ. NFRQ) IFAR=-1
      IF( NFRQ.NE.1) GOTO 120
      WRITE( 6,135)
      GOTO 14
  120 MHZ= MHZ+1
      IF( MHZ.LE. NFRQ) GOTO 42
      IF( IPED.EQ.0) GOTO 123
      IF( NVQD.LT.1) GOTO 199
      WRITE( 6,184)  IVQD( NVQD), ZPNORM
      GOTO 204
  199 WRITE( 6,184)  ISANT( NSANT), ZPNORM
  204 ITMP1= NFRQ
      IF( ITMP1.LE.( NORMF/4)) GOTO 121
      ITMP1= NORMF/4
      WRITE( 6,185)
  121 IF( IFRQ.EQ.0) TMP1= FMHZ-( NFRQ-1)* DELFRQ
      IF( IFRQ.EQ.1) TMP1= FMHZ/( DELFRQ**( NFRQ-1))
      DO 122  I=1, ITMP1
      ITMP2= I+4*( I-1)
      TMP2= FNORM( ITMP2)/ ZPNORM
      TMP3= FNORM( ITMP2+1)/ ZPNORM
      TMP4= FNORM( ITMP2+2)/ ZPNORM
      TMP5= FNORM( ITMP2+3)
      WRITE( 6,186)  TMP1, FNORM( ITMP2), FNORM( ITMP2+1), FNORM( ITMP2
     &+2), FNORM( ITMP2+3), TMP2, TMP3, TMP4, TMP5
      IF( IFRQ.EQ.0) TMP1= TMP1+ DELFRQ
      IF( IFRQ.EQ.1) TMP1= TMP1* DELFRQ
  122 CONTINUE
      WRITE( 6,135)
  123 CONTINUE
      NFRQ=1
      MHZ=1
      GOTO 14
  125 FORMAT(A2,19A4)
  126 FORMAT('1')
  127 FORMAT(///,33X,'************************************',//,36X,
     &'NUMERICAL ELECTROMAGNETICS CODE',//,33X,
     &'************************************')
  128 FORMAT(////,37X,'- - - - COMMENTS - - - -',//)
  129 FORMAT(25X,20A4)
  130 FORMAT(///,10X,'INCORRECT LABEL FOR A COMMENT CARD')
  135 FORMAT(/////)
  136 FORMAT(A2,I3,3I5,6E10.3)
  137 FORMAT(1X,'***** DATA CARD NO.',I3,3X,A2,1X,I3,3(1X,I5),6(1X,1P,E
     &12.5))
  138 FORMAT(///,10X,'FAULTY DATA CARD LABEL AFTER GEOMETRY SECTION')
  139 FORMAT(///,10X,'NUMBER OF LOADING CARDS EXCEEDS STORAGE ALLOTTED'
     &)
  140 FORMAT(///,10X,'DATA FAULT ON LOADING CARD NO.=',I5,5X,'ITAG S',
     &'TEP1=',I5,'  IS GREATER THAN ITAG STEP2=',I5)
  141 FORMAT(///,10X,'NUMBER OF EXCITATION CARDS EXCEEDS STORAGE ALLO',
     &'TTED')
  142 FORMAT(///,10X,'NUMBER OF NETWORK CARDS EXCEEDS STORAGE ALLOTTED'
     &)
  143 FORMAT(///,10X,'WHEN MULTIPLE FREQUENCIES ARE REQUESTED, ONLY ONE
     & NEAR FIELD CARD CAN BE USED -',/,10X,'LAST CARD READ IS USED')
  145 FORMAT(////,33X,'- - - - - - FREQUENCY - - - - - -',//,36X,'FR',
     &'EQUENCY=',1P,E11.4,' MHZ',/,36X,'WAVELENGTH=',E11.4,' METERS')
  146 FORMAT(///,30X,' - - - STRUCTURE IMPEDANCE LOADING - - -')
  147 FORMAT(/,35X,'THIS STRUCTURE IS NOT LOADED')
  148 FORMAT(///,34X,'- - - ANTENNA ENVIRONMENT - - -',/)
  149 FORMAT(40X,'MEDIUM UNDER SCREEN -')
  150 FORMAT(40X,'RELATIVE DIELECTRIC CONST.=',F7.3,/,40X,'CONDUCTIV',
     &'ITY=',1P,E10.3,' MHOS/METER',/,40X,
     &'COMPLEX DIELECTRIC CONSTANT=',2E12.5)
  151 FORMAT(42X,'PERFECT GROUND')
  152 FORMAT(44X,'FREE SPACE')
  153 FORMAT(///,32X,'- - - MATRIX TIMING - - -',//,24X,'FILL=',F9.3,
     &' SEC.,  FACTOR=',F9.3,' SEC.')
  154 FORMAT(///,40X,'- - - EXCITATION - - -')
  155 FORMAT(/,4X,'PLANE WAVE',4X,'THETA=',F7.2,' DEG,  PHI=',F7.2,
     &' DEG,  ETA=',F7.2,' DEG,  TYPE -',A6,'=  AXIAL RATIO=',F6.3)
  156 FORMAT(/,31X,'POSITION (METERS)',14X,'ORIENTATION (DEG)=/',28X,
     &'X',12X,'Y',12X,'Z',10X,'ALPHA',5X,'BETA',4X,'DIPOLE MOMENT',//,4
     &X,'CURRENT SOURCE',1X,3(3X,F10.5),1X,2(3X,F7.2),4X,F8.3)
  157 FORMAT(4X,4(I5,1X),1P,6(3X,E11.4),3X,A6,A2)
  158 FORMAT(///,44X,'- - - NETWORK DATA - - -')
  159 FORMAT(/,6X,'- FROM -    - TO -',11X,'TRANSMISSION LINE',15X,
     &'-  -  SHUNT ADMITTANCES (MHOS)  -  -',14X,'LINE',/,6X,
     &'TAG  SEG.','   TAG  SEG.',6X,'IMPEDANCE',6X,'LENGTH',12X,
     &'- END ONE -',17X,'- END TWO -',12X,'TYPE',/,6X,
     &'NO.   NO.   NO.   NO.',9X,'OHM''S',8X,'METERS',9X,'REAL',10X,
     &'IMAG.',9X,'REAL',10X,'IMAG.')
  160 FORMAT(/,6X,'- FROM -',4X,'- TO -',26X,'-  -  ADMITTANCE MATRIX',
     &' ELEMENTS (MHOS)  -  -',/,6X,'TAG  SEG.   TAG  SEG.',13X,'(ON',
     &'E,ONE)',19X,'(ONE,TWO)',19X,'(TWO,TWO)',/,6X,'NO.   NO.   NO.',
     &'   NO.',8X,'REAL',10X,'IMAG.',9X,'REAL',10X,'IMAG.',9X,'REAL',10
     &X,'IMAG.')
  161 FORMAT(///,29X,'- - - CURRENTS AND LOCATION - - -',//,33X,'DIS',
     &'TANCES IN WAVELENGTHS')
  162 FORMAT(//,2X,'SEG.',2X,'TAG',4X,'COORD. OF SEG. CENTER',5X,'SEG.'
     &,12X,'- - - CURRENT (AMPS) - - -',/,2X,'NO.',3X,'NO.',5X,'X',8X,
     &'Y',8X,'Z',6X,'LENGTH',5X,'REAL',8X,'IMAG.',7X,'MAG.',8X,'PHASE')
  163 FORMAT(///,33X,'- - - RECEIVING PATTERN PARAMETERS - - -',/,43X,
     &'ETA=',F7.2,' DEGREES',/,43X,'TYPE -',A6,/,43X,'AXIAL RATIO=',F6.
     &3,//,11X,'THETA',6X,'PHI',10X,'-  CURRENT  -',9X,'SEG',/,11X,
     &'(DEG)',5X,'(DEG)',7X,'MAGNITUDE',4X,'PHASE',6X,'NO.',/)
  164 FORMAT(10X,2(F7.2,3X),1X,1P,E11.4,3X,0P,F7.2,4X,I5)
  165 FORMAT(1X,2I5,3F9.4,F9.5,1X,1P,3E12.4,0P,F9.3)
  166 FORMAT(///,40X,'- - - POWER BUDGET - - -',//,43X,'INPUT PO',
     &'WER   =',1P,E11.4,' WATTS',/,43X,'RADIATED POWER=',E11.4,
     &' WATTS',/,43X,'STRUCTURE LOSS=',E11.4,' WATTS',/,43X,
     &'NETWORK LOSS  =',E11.4,' WATTS',/,43X,'EFFICIENCY    =',0P,F7.2,
     &' PERCENT')
  170 FORMAT(40X,'RADIAL WIRE GROUND SCREEN',/,40X,I5,' WIRES',/,40X,
     &'WIRE LENGTH=',F8.2,' METERS',/,40X,'WIRE RADIUS=',1P,E10.3,
     &' METERS')
  181 FORMAT(///,4X,'RECEIVING PATTERN STORAGE TOO SMALL,ARRAY TRUNCA',
     &'TED')
  182 FORMAT(///,32X,'- - - NORMALIZED RECEIVING PATTERN - - -',/,41X,
     &'NORMALIZATION FACTOR=',1P,E11.4,/,41X,'ETA=',0P,F7.2,' DEGREES',
     &/,41X,'TYPE -',A6,/,41X,'AXIAL RATIO=',F6.3,/,41X,'SEGMENT NO.=',
     &I5,//,21X,'THETA',6X,'PHI',9X,'-  PATTERN  -',/,21X,'(DEG)',5X,
     &'(DEG)',8X,'DB',8X,'MAGNITUDE',/)
  183 FORMAT(20X,2(F7.2,3X),1X,F7.2,4X,1P,E11.4)
  184 FORMAT(///,36X,'- - - INPUT IMPEDANCE DATA - - -',/,45X,'SO',
     &'URCE SEGMENT NO.',I4,/,45X,'NORMALIZATION FACTOR=',1P,E12.5,//,7
     &X,'FREQ.',13X,'-  -  UNNORMALIZED IMPEDANCE  -  -',21X,'-'
     &' -  NORMALIZED IMPEDANCE  -  -',/,19X,'RESISTANCE',4X,'REACTA',
     &'NCE',6X,'MAGNITUDE',4X,'PHASE',7X,'RESISTANCE',4X,'REACTANCE',6X
     &,'MAGNITUDE',4X,'PHASE',/,8X,'MHZ',11X,'OHMS',10X,'OHMS',11X,
     &'OHMS',5X,'DEGREES',47X,'DEGREES',/)
  185 FORMAT(///,4X,'STORAGE FOR IMPEDANCE NORMALIZATION TOO SMALL, A',
     &'RRAY TRUNCATED')
  186 FORMAT(3X,F9.3,2X,1P,2(2X,E12.5),3X,E12.5,2X,0P,F7.2,2X,1P,2(2X,E
     &12.5),3X,E12.5,2X,0P,F7.2)
  196 FORMAT(////,20X,'APPROXIMATE INTEGRATION EMPLOYED FOR SEGMENT',
     &'S MORE THAN',F8.3,' WAVELENGTHS APART')
  197 FORMAT(////,41X,'- - - - SURFACE PATCH CURRENTS - - - -',//,50X,
     &'DISTANCE IN WAVELENGTHS',/,50X,'CURRENT IN AMPS/METER',//,28X,
     &'- - SURFACE COMPONENTS - -',19X,'- - - RECTANGULAR COM',
     &'PONENTS - - -',/,6X,'PATCH CENTER',6X,'TANGENT VECTOR 1',3X,
     &'TANGENT VECTOR 2',11X,'X',19X,'Y',19X,'Z',/,5X,'X',6X,'Y',6X,'Z'
     &,5X,'MAG.',7X,'PHASE',3X,'MAG.',7X,'PHASE',3(4X,'REAL',6X,'IMAG.'
     &))
  198 FORMAT(1X,I4,/,1X,3F7.3,2(1P,E11.4,0P,F8.2),1P,6E10.2)
  201 FORMAT(/,' RUN TIME =',F10.3)
  315 FORMAT(///,34X,'- - - CHARGE DENSITIES - - -',//,36X,
     &'DISTANCES IN WAVELENGTHS',///,2X,'SEG.',2X,'TAG',4X,
     &'COORD. OF SEG. CENTER',5X,'SEG.',10X,
     &'CHARGE DENSITY (COULOMBS/METER)',/,2X,'NO.',3X,'NO.',5X,'X',8X,
     &'Y',8X,'Z',6X,'LENGTH',5X,'REAL',8X,'IMAG.',7X,'MAG.',8X,'PHASE')
     &
  321 FORMAT(/,20X,'THE EXTENDED THIN WIRE KERNEL WILL BE USED')
  303 FORMAT(/,' ERROR - ',A2,' CARD IS NOT ALLOWED WITH N.G.F.')
  327 FORMAT(/,35X,' LOADING ONLY IN N.G.F. SECTION')
  302 FORMAT(' ERROR - N.G.F. IN USE.  CANNOT WRITE NEW N.G.F.')
  313 FORMAT(/,' NUMBER OF SEGMENTS IN COUPLING CALCULATION (CP) EXCEE'
     &,'DS LIMIT')
  390 FORMAT(' RADIAL WIRE G. S. APPROXIMATION MAY NOT BE USED WITH SO'
     &,'MMERFELD GROUND OPTION')
  391 FORMAT(40X,'FINITE GROUND.  REFLECTION COEFFICIENT APPROXIMATION'
     &)
  392 FORMAT(40X,'FINITE GROUND.  SOMMERFELD SOLUTION')
  393 FORMAT(/,' ERROR IN GROUND PARAMETERS -',/,' COMPLEX DIELECTRIC',
     &' CONSTANT FROM FILE IS',1P,2E12.5,/,32X,'REQUESTED',2E12.5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE ARC( ITG, NS, RADA, ANG1, ANG2, RAD)
C ***
C
C     ARC GENERATES SEGMENT GEOMETRY DATA FOR AN ARC OF NS SEGMENTS
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      DIMENSION  X2(1), Y2(1), Z2(1)
      EQUIVALENCE(X2,SI),(Y2,ALP),(Z2,BET)
      DATA   TA/.01745329252D+0/
      IST= N+1
      N= N+ NS
      NP= N
      MP= M
      IPSYM=0
      IF( NS.LT.1) RETURN
      IF( ABS( ANG2- ANG1).LT.360.00001D+0) GOTO 1
      WRITE( 6,3)
      STOP
    1 ANG= ANG1* TA
      DANG=( ANG2- ANG1)* TA/ NS
      XS1= RADA* COS( ANG)
      ZS1= RADA* SIN( ANG)
      DO 2  I= IST, N
      ANG= ANG+ DANG
      XS2= RADA* COS( ANG)
      ZS2= RADA* SIN( ANG)
      X( I)= XS1
      Y( I)=0.
      Z( I)= ZS1
      X2( I)= XS2
      Y2( I)=0.
      Z2( I)= ZS2
      XS1= XS2
      ZS1= ZS2
      BI( I)= RAD
    2 ITAG( I)= ITG
C
      RETURN
    3 FORMAT(' ERROR -- ARC ANGLE EXCEEDS 360. DEGREES')
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      FUNCTION ATGN2( X, Y)
C ***
C
C     ATGN2 IS ARCTANGENT FUNCTION MODIFIED TO RETURN 0. WHEN X=Y=0.
C
      IMPLICIT REAL (A-H,O-Z)
      IF( X) 3,1,3
    1 IF( Y) 3,2,3
    2 ATGN2=0.
      RETURN
    3 ATGN2= ATAN2( X, Y)
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE BLCKOT( AR, NUNIT, IX1, IX2, NBLKS, NEOF)
C ***
C
C     BLCKOT CONTROLS THE READING AND WRITING OF MATRIX BLOCKS ON FILES
C     FOR THE OUT-OF-CORE MATRIX SOLUTION.
C
      IMPLICIT REAL (A-H,O-Z)
C      LOGICAL  ENF
      COMPLEX  AR
      DIMENSION  AR(1000)
      I1=( IX1+1)/2
      I2=( IX2+1)/2
    1 WRITE( NUNIT) ( AR( J), J= I1, I2)
      RETURN
      ENTRY BLCKIN( AR, NUNIT, IX1, IX2, NBLKS, NEOF)
      I1=( IX1+1)/2
      I2=( IX2+1)/2
      DO 2  I=1, NBLKS
C     IF (ENF(NUNIT)) GO TO 3
      READ( NUNIT,END=3) ( AR( J), J= I1, I2)
    2 CONTINUE
      RETURN
    3 WRITE( 6,4)  NUNIT, NBLKS, NEOF
      IF( NEOF.NE.777) STOP
      NEOF=0
C
      RETURN
    4 FORMAT('  EOF ON UNIT',I3,'  NBLKS= ',I3,'  NEOF= ',I5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE CABC( CURX)
C ***
C
C     CABC COMPUTES COEFFICIENTS OF THE CONSTANT (A), SINE (B), AND
C     COSINE (C) TERMS IN THE CURRENT INTERPOLATION FUNCTIONS FOR THE
C     CURRENT VECTOR CUR.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CUR, CURX, VQDS, CURD, CCJ, VSANT, VQD, CS1, CS2
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
     &CII( NM), CUR( N3M)
      COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
     &NSCON, IPCON(10), NPCON
      COMMON  /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
     &, IQDS(30), NVQD, NSANT, NQDS
      COMMON  /ANGL/ SALP( NM)
      DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
      DIMENSION  CURX(1), CCJX(2)
      EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
     &T2Z,ITAG)
      EQUIVALENCE(CCJ,CCJX)
      DATA   TP/6.283185308D+0/, CCJX/0.,-0.01666666667D+0/
      IF( N.EQ.0) GOTO 6
      DO 1  I=1, N
      AIR( I)=0.
      AII( I)=0.
      BIR( I)=0.
      BII( I)=0.
      CIR( I)=0.
    1 CII( I)=0.
      DO 2  I=1, N
      AR= REAL( CURX( I))
      AI= AIMAG( CURX( I))
      CALL TBF( I,1)
      DO 2  JX=1, JSNO
      J= JCO( JX)
      AIR( J)= AIR( J)+ AX( JX)* AR
      AII( J)= AII( J)+ AX( JX)* AI
      BIR( J)= BIR( J)+ BX( JX)* AR
      BII( J)= BII( J)+ BX( JX)* AI
      CIR( J)= CIR( J)+ CX( JX)* AR
    2 CII( J)= CII( J)+ CX( JX)* AI
      IF( NQDS.EQ.0) GOTO 4
      DO 3  IS=1, NQDS
      I= IQDS( IS)
      JX= ICON1( I)
      ICON1( I)=0
      CALL TBF( I,0)
      ICON1( I)= JX
      SH= SI( I)*.5
      CURD= CCJ* VQDS( IS)/(( LOG(2.* SH/ BI( I))-1.)*( BX( JSNO)* COS(
     & TP* SH)+ CX( JSNO)* SIN( TP* SH))* WLAM)
      AR= REAL( CURD)
      AI= AIMAG( CURD)
      DO 3  JX=1, JSNO
      J= JCO( JX)
      AIR( J)= AIR( J)+ AX( JX)* AR
      AII( J)= AII( J)+ AX( JX)* AI
      BIR( J)= BIR( J)+ BX( JX)* AR
      BII( J)= BII( J)+ BX( JX)* AI
      CIR( J)= CIR( J)+ CX( JX)* AR
    3 CII( J)= CII( J)+ CX( JX)* AI
    4 DO 5  I=1, N
    5 CURX( I)= CMPLX( AIR( I)+ CIR( I), AII( I)+ CII( I))
C     CONVERT SURFACE CURRENTS FROM T1,T2 COMPONENTS TO X,Y,Z COMPONENTS
    6 IF( M.EQ.0) RETURN
      K= LD- M
      JCO1= N+2* M+1
      JCO2= JCO1+ M
      DO 7  I=1, M
      K= K+1
      JCO1= JCO1-2
      JCO2= JCO2-3
      CS1= CURX( JCO1)
      CS2= CURX( JCO1+1)
      CURX( JCO2)= CS1* T1X( K)+ CS2* T2X( K)
      CURX( JCO2+1)= CS1* T1Y( K)+ CS2* T2Y( K)
    7 CURX( JCO2+2)= CS1* T1Z( K)+ CS2* T2Z( K)
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      FUNCTION CANG( Z)
C ***
C
C     CANG RETURNS THE PHASE ANGLE OF A COMPLEX NUMBER IN DEGREES.
C
      IMPLICIT REAL (A-H,O-Z)
      COMPLEX  Z
      CANG= ATGN2( AIMAG( Z), REAL( Z))*57.29577951D+0
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE CMNGF( CB, CC, CD, NB, NC, ND, RKHX, IEXKX)
C ***
      IMPLICIT REAL (A-H,O-Z)
C     CMNGF FILLS INTERACTION MATRICIES B, C, AND D FOR N.G.F. SOLUTION
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CB, CC, CD, ZARRAY, EXK, EYK, EZK, EXS, EYS, EZS, EXC
     &, EYC, EZC
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
      COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
     &NSCON, IPCON(10), NPCON
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      DIMENSION  CB( NB,1), CC( NC,1), CD( ND,1)
      RKH= RKHX
      IEXK= IEXKX
      M1EQ=2* M1
      M2EQ= M1EQ+1
      MEQ=2* M
      NEQP= ND- NPCON*2
      NEQS= NEQP- NSCON
      NEQSP= NEQS+ NC
      NEQN= NC+ N- N1
      ITX=1
      IF( NSCON.GT.0) ITX=2
      IF( ICASX.EQ.1) GOTO 1
      REWIND 12
      REWIND 14
      REWIND 15
      IF( ICASX.GT.2) GOTO 5
    1 DO 4  J=1, ND
      DO 2  I=1, ND
    2 CD( I, J)=(0.,0.)
      DO 3  I=1, NB
      CB( I, J)=(0.,0.)
    3 CC( I, J)=(0.,0.)
    4 CONTINUE
    5 IST= N- N1+1
      IT= NPBX
C     LOOP THRU 24 FILLS B.  FOR ICASX=1 OR 2 ALSO FILLS D(WW), D(WS)
      ISV=- NPBX
      DO 24  IBLK=1, NBBX
      ISV= ISV+ NPBX
      IF( IBLK.EQ. NBBX) IT= NLBX
      IF( ICASX.LT.3) GOTO 7
      DO 6  J=1, ND
      DO 6  I=1, IT
    6 CB( I, J)=(0.,0.)
    7 I1= ISV+1
      I2= ISV+ IT
      IN2= I2
      IF( IN2.GT. N1) IN2= N1
      IM1= I1- N1
      IM2= I2- N1
      IF( IM1.LT.1) IM1=1
      IMX=1
      IF( I1.LE. N1) IMX= N1- I1+2
C     FILL B(WW),B(WS).  FOR ICASX=1,2 FILL D(WW),D(WS)
      IF( N2.GT. N) GOTO 12
      DO 11  J= N2, N
      CALL TRIO( J)
      DO 9  I=1, JSNO
      JSS= JCO( I)
C     SET JCO WHEN SOURCE IS NEW BASIS FUNCTION ON NEW SEGMENT
      IF( JSS.LT. N2) GOTO 8
      JCO( I)= JSS- N1
C     SOURCE IS PORTION OF MODIFIED BASIS FUNCTION ON NEW SEGMENT
      GOTO 9
    8 JCO( I)= NEQS+ ICONX( JSS)
    9 CONTINUE
      IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CB, NB, CB, NB,0)
      IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CB( IMX,1), NB, CB, NB,0
     &)
      IF( ICASX.GT.2) GOTO 11
      CALL CMWW( J, N2, N, CD, ND, CD, ND,1)
C     LOADING IN D(WW)
      IF( M2.LE. M) CALL CMWS( J, M2EQ, MEQ, CD(1, IST), ND, CD, ND,1)
      IF( NLOAD.EQ.0) GOTO 11
      IR= J- N1
      EXK= ZARRAY( J)
      DO 10  I=1, JSNO
      JSS= JCO( I)
   10 CD( JSS, IR)= CD( JSS, IR)-( AX( I)+ CX( I))* EXK
   11 CONTINUE
C     FILL B(WW)PRIME
   12 IF( NSCON.EQ.0) GOTO 20
      DO 19  I=1, NSCON
C     SOURCES ARE NEW OR MODIFIED BASIS FUNCTIONS ON OLD SEGMENTS WHICH
C     CONNECT TO NEW SEGMENTS
      J= ISCON( I)
      CALL TRIO( J)
      JSS=0
      DO 15  IX=1, JSNO
      IR= JCO( IX)
      IF( IR.LT. N2) GOTO 13
      IR= IR- N1
      GOTO 14
   13 IR= ICONX( IR)
      IF( IR.EQ.0) GOTO 15
      IR= NEQS+ IR
   14 JSS= JSS+1
      JCO( JSS)= IR
      AX( JSS)= AX( IX)
      BX( JSS)= BX( IX)
      CX( JSS)= CX( IX)
   15 CONTINUE
      JSNO= JSS
      IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CB, NB, CB, NB,0)
C     SOURCE IS SINGULAR COMPONENT OF PATCH CURRENT THAT IS PART OF
C     MODIFIED BASIS FUNCTION FOR OLD SEGMENT THAT CONNECTS TO A NEW
C     SEGMENT ON END OPPOSITE PATCH.
      IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CB( IMX,1), NB, CB, NB,0
     &)
      IF( I1.LE. IN2) CALL CMSW( J, I, I1, IN2, CB, CB,0, NB,-1)
      IF( NLODF.EQ.0) GOTO 17
      JX= J- ISV
      IF( JX.LT.1.OR. JX.GT. IT) GOTO 17
      EXK= ZARRAY( J)
      DO 16  IX=1, JSNO
      JSS= JCO( IX)
C     SOURCES ARE PORTIONS OF MODIFIED BASIS FUNCTION J ON OLD SEGMENTS
C     EXCLUDING OLD SEGMENTS THAT DIRECTLY CONNECT TO NEW SEGMENTS.
   16 CB( JX, JSS)= CB( JX, JSS)-( AX( IX)+ CX( IX))* EXK
   17 CALL TBF( J,1)
      JSX= JSNO
      JSNO=1
      IR= JCO(1)
      JCO(1)= NEQS+ I
      DO 19  IX=1, JSX
      IF( IX.EQ.1) GOTO 18
      IR= JCO( IX)
      AX(1)= AX( IX)
      BX(1)= BX( IX)
      CX(1)= CX( IX)
   18 IF( IR.GT. N1) GOTO 19
      IF( ICONX( IR).NE.0) GOTO 19
      IF( I1.LE. IN2) CALL CMWW( IR, I1, IN2, CB, NB, CB, NB,0)
C     LOADING FOR B(WW)PRIME
      IF( IM1.LE. IM2) CALL CMWS( IR, IM1, IM2, CB( IMX,1), NB, CB, NB,
     &0)
      IF( NLODF.EQ.0) GOTO 19
      JX= IR- ISV
      IF( JX.LT.1.OR. JX.GT. IT) GOTO 19
      EXK= ZARRAY( IR)
      JSS= JCO(1)
      CB( JX, JSS)= CB( JX, JSS)-( AX(1)+ CX(1))* EXK
   19 CONTINUE
   20 IF( NPCON.EQ.0) GOTO 22
C     FILL B(SS)PRIME TO SET OLD PATCH BASIS FUNCTIONS TO ZERO FOR
C     PATCHES THAT CONNECT TO NEW SEGMENTS
      JSS= NEQP
      DO 21  I=1, NPCON
      IX= IPCON( I)*2+ N1- ISV
      IR= IX-1
      JSS= JSS+1
      IF( IR.GT.0.AND. IR.LE. IT) CB( IR, JSS)=(1.,0.)
      JSS= JSS+1
      IF( IX.GT.0.AND. IX.LE. IT) CB( IX, JSS)=(1.,0.)
   21 CONTINUE
C     FILL B(SW) AND B(SS)
   22 IF( M2.GT. M) GOTO 23
      IF( I1.LE. IN2) CALL CMSW( M2, M, I1, IN2, CB(1, IST), CB, N1, NB
     &,0)
      IF( IM1.LE. IM2) CALL CMSS( M2, M, IM1, IM2, CB( IMX, IST), NB,0)
     &
   23 IF( ICASX.EQ.1) GOTO 24
      WRITE( 14) (( CB( I, J), I=1, IT), J=1, ND)
C     FILLING B COMPLETE.  START ON C AND D
   24 CONTINUE
      IT= NPBL
      ISV=- NPBL
      DO 43  IBLK=1, NBBL
      ISV= ISV+ NPBL
      ISVV= ISV+ NC
      IF( IBLK.EQ. NBBL) IT= NLBL
      IF( ICASX.LT.3) GOTO 27
      DO 26  J=1, IT
      DO 25  I=1, NC
   25 CC( I, J)=(0.,0.)
      DO 26  I=1, ND
   26 CD( I, J)=(0.,0.)
   27 I1= ISVV+1
      I2= ISVV+ IT
      IN1= I1- M1EQ
      IN2= I2- M1EQ
      IF( IN2.GT. N) IN2= N
      IM1= I1- N
      IM2= I2- N
      IF( IM1.LT. M2EQ) IM1= M2EQ
      IF( IM2.GT. MEQ) IM2= MEQ
      IMX=1
      IF( IN1.LE. IN2) IMX= NEQN- I1+2
      IF( ICASX.LT.3) GOTO 32
C     SAME AS DO 24 LOOP TO FILL D(WW) FOR ICASX GREATER THAN 2
      IF( N2.GT. N) GOTO 32
      DO 31  J= N2, N
      CALL TRIO( J)
      DO 29  I=1, JSNO
      JSS= JCO( I)
      IF( JSS.LT. N2) GOTO 28
      JCO( I)= JSS- N1
      GOTO 29
   28 JCO( I)= NEQS+ ICONX( JSS)
   29 CONTINUE
      IF( IN1.LE. IN2) CALL CMWW( J, IN1, IN2, CD, ND, CD, ND,1)
      IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CD(1, IMX), ND, CD, ND,1
     &)
      IF( NLOAD.EQ.0) GOTO 31
      IR= J- N1- ISV
      IF( IR.LT.1.OR. IR.GT. IT) GOTO 31
      EXK= ZARRAY( J)
      DO 30  I=1, JSNO
      JSS= JCO( I)
   30 CD( JSS, IR)= CD( JSS, IR)-( AX( I)+ CX( I))* EXK
   31 CONTINUE
C     FILL D(SW) AND D(SS)
   32 IF( M2.GT. M) GOTO 33
      IF( IN1.LE. IN2) CALL CMSW( M2, M, IN1, IN2, CD( IST,1), CD, N1,
     &ND,1)
      IF( IM1.LE. IM2) CALL CMSS( M2, M, IM1, IM2, CD( IST, IMX), ND,1)
     &
C     FILL C(WW),C(WS), D(WW)PRIME, AND D(WS)PRIME.
   33 IF( N1.LT.1) GOTO 39
      DO 37  J=1, N1
      CALL TRIO( J)
      IF( NSCON.EQ.0) GOTO 36
      DO 35  IX=1, JSNO
      JSS= JCO( IX)
      IF( JSS.LT. N2) GOTO 34
      JCO( IX)= JSS+ M1EQ
      GOTO 35
   34 IR= ICONX( JSS)
      IF( IR.NE.0) JCO( IX)= NEQSP+ IR
   35 CONTINUE
   36 IF( IN1.LE. IN2) CALL CMWW( J, IN1, IN2, CC, NC, CD, ND, ITX)
      IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CC(1, IMX), NC, CD(1,
     &IMX), ND, ITX)
   37 CONTINUE
C     FILL C(WW)PRIME
      IF( NSCON.EQ.0) GOTO 39
      DO 38  IX=1, NSCON
      IR= ISCON( IX)
      JSS= NEQS+ IX- ISV
      IF( JSS.GT.0.AND. JSS.LE. IT) CC( IR, JSS)=(1.,0.)
   38 CONTINUE
   39 IF( NPCON.EQ.0) GOTO 41
C     FILL C(SS)PRIME
      JSS= NEQP- ISV
      DO 40  I=1, NPCON
      IX= IPCON( I)*2+ N1
      IR= IX-1
      JSS= JSS+1
      IF( JSS.GT.0.AND. JSS.LE. IT) CC( IR, JSS)=(1.,0.)
      JSS= JSS+1
      IF( JSS.GT.0.AND. JSS.LE. IT) CC( IX, JSS)=(1.,0.)
   40 CONTINUE
C     FILL C(SW) AND C(SS)
   41 IF( M1.LT.1) GOTO 42
      IF( IN1.LE. IN2) CALL CMSW(1, M1, IN1, IN2, CC( N2,1), CC,0, NC,1
     &)
      IF( IM1.LE. IM2) CALL CMSS(1, M1, IM1, IM2, CC( N2, IMX), NC,1)
   42 CONTINUE
      IF( ICASX.EQ.1) GOTO 43
      WRITE( 12) (( CD( J, I), J=1, ND), I=1, IT)
      WRITE( 15) (( CC( J, I), J=1, NC), I=1, IT)
   43 CONTINUE
      IF( ICASX.EQ.1) RETURN
      REWIND 12
      REWIND 14
      REWIND 15
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE CMSET( NROW, CM, RKHX, IEXKX)
C ***
      IMPLICIT REAL (A-H,O-Z)
C
C     CMSET SETS UP THE COMPLEX STRUCTURE MATRIX IN THE ARRAY CM
C
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CM, ZARRAY, ZAJ, ETK, ETS, ETC, EXK, EYK, EZK, EXS,
     &EYS, EZS, EXC, EYC, EZC, SSX, D, DETER
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      COMMON  /SMAT/ SSX(16,16)
      COMMON  /SCRATM/ D( N2M)
      COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
      COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
     &NSCON, IPCON(10), NPCON
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      DIMENSION  CM( NROW,1)
      MP2=2* MP
      NPEQ= NP+ MP2
      NEQ= N+2* M
      NOP= NEQ/ NPEQ
      IF( ICASE.GT.2) REWIND 11
      RKH= RKHX
      IEXK= IEXKX
      IOUT=2* NPBLK* NROW
C
C     CYCLE OVER MATRIX BLOCKS
C
      IT= NPBLK
      DO 13  IXBLK1=1, NBLOKS
      ISV=( IXBLK1-1)* NPBLK
      IF( IXBLK1.EQ. NBLOKS) IT= NLAST
      DO 1  I=1, NROW
      DO 1  J=1, IT
    1 CM( I, J)=(0.,0.)
      I1= ISV+1
      I2= ISV+ IT
      IN2= I2
      IF( IN2.GT. NP) IN2= NP
      IM1= I1- NP
      IM2= I2- NP
      IF( IM1.LT.1) IM1=1
      IST=1
      IF( I1.LE. NP) IST= NP- I1+2
C
C     WIRE SOURCE LOOP
C
      IF( N.EQ.0) GOTO 5
      DO 4  J=1, N
      CALL TRIO( J)
      DO 2  I=1, JSNO
      IJ= JCO( I)
    2 JCO( I)=(( IJ-1)/ NP)* MP2+ IJ
      IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CM, NROW, CM, NROW,1)
      IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CM(1, IST), NROW, CM,
     &NROW,1)
C
C     MATRIX ELEMENTS MODIFIED BY LOADING
C
      IF( NLOAD.EQ.0) GOTO 4
      IF( J.GT. NP) GOTO 4
      IPR= J- ISV
      IF( IPR.LT.1.OR. IPR.GT. IT) GOTO 4
      ZAJ= ZARRAY( J)
      DO 3  I=1, JSNO
      JSS= JCO( I)
    3 CM( JSS, IPR)= CM( JSS, IPR)-( AX( I)+ CX( I))* ZAJ
    4 CONTINUE
C     MATRIX ELEMENTS FOR PATCH CURRENT SOURCES
    5 IF( M.EQ.0) GOTO 7
      JM1=1- MP
      JM2=0
      JST=1- MP2
      DO 6  I=1, NOP
      JM1= JM1+ MP
      JM2= JM2+ MP
      JST= JST+ NPEQ
      IF( I1.LE. IN2) CALL CMSW( JM1, JM2, I1, IN2, CM( JST,1), CM,0,
     &NROW,1)
      IF( IM1.LE. IM2) CALL CMSS( JM1, JM2, IM1, IM2, CM( JST, IST),
     &NROW,1)
    6 CONTINUE
    7 IF( ICASE.EQ.1) GOTO 13
C     COMBINE ELEMENTS FOR SYMMETRY MODES
      IF( ICASE.EQ.3) GOTO 12
      DO 11  I=1, IT
      DO 11  J=1, NPEQ
      DO 8  K=1, NOP
      KA= J+( K-1)* NPEQ
    8 D( K)= CM( KA, I)
      DETER= D(1)
      DO 9  KK=2, NOP
    9 DETER= DETER+ D( KK)
      CM( J, I)= DETER
      DO 11  K=2, NOP
      KA= J+( K-1)* NPEQ
      DETER= D(1)
      DO 10  KK=2, NOP
   10 DETER= DETER+ D( KK)* SSX( K, KK)
      CM( KA, I)= DETER
   11 CONTINUE
C     WRITE BLOCK FOR OUT-OF-CORE CASES.
      IF( ICASE.LT.3) GOTO 13
   12 CALL BLCKOT( CM,11,1, IOUT,1,31)
   13 CONTINUE
      IF( ICASE.GT.2) REWIND 11
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE CMSS( J1, J2, IM1, IM2, CM, NROW, ITRP)
C ***
      IMPLICIT REAL (A-H,O-Z)
C     CMSS COMPUTES MATRIX ELEMENTS FOR SURFACE-SURFACE INTERACTIONS.
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  G11, G12, G21, G22, CM, EXK, EYK, EZK, EXS, EYS, EZS,
     & EXC, EYC, EZC
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ANGL/ SALP( NM)
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      DIMENSION  CM( NROW,1)
      DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
      EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
     &T2Z,ITAG)
      EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
     &IND1),(T2ZJ,IND2)
      LDP= LD+1
      I1=( IM1+1)/2
      I2=( IM2+1)/2
      ICOMP= I1*2-3
      II1=-1
C     LOOP OVER OBSERVATION PATCHES
      IF( ICOMP+2.LT. IM1) II1=-2
      DO 5  I= I1, I2
      IL= LDP- I
      ICOMP= ICOMP+2
      II1= II1+2
      II2= II1+1
      T1XI= T1X( IL)* SALP( IL)
      T1YI= T1Y( IL)* SALP( IL)
      T1ZI= T1Z( IL)* SALP( IL)
      T2XI= T2X( IL)* SALP( IL)
      T2YI= T2Y( IL)* SALP( IL)
      T2ZI= T2Z( IL)* SALP( IL)
      XI= X( IL)
      YI= Y( IL)
      ZI= Z( IL)
C     LOOP OVER SOURCE PATCHES
      JJ1=-1
      DO 5  J= J1, J2
      JL= LDP- J
      JJ1= JJ1+2
      JJ2= JJ1+1
      S= BI( JL)
      XJ= X( JL)
      YJ= Y( JL)
      ZJ= Z( JL)
      T1XJ= T1X( JL)
      T1YJ= T1Y( JL)
      T1ZJ= T1Z( JL)
      T2XJ= T2X( JL)
      T2YJ= T2Y( JL)
      T2ZJ= T2Z( JL)
      CALL HINTG( XI, YI, ZI)
      G11=-( T2XI* EXK+ T2YI* EYK+ T2ZI* EZK)
      G12=-( T2XI* EXS+ T2YI* EYS+ T2ZI* EZS)
      G21=-( T1XI* EXK+ T1YI* EYK+ T1ZI* EZK)
      G22=-( T1XI* EXS+ T1YI* EYS+ T1ZI* EZS)
      IF( I.NE. J) GOTO 1
      G11= G11-.5
      G22= G22+.5
C     NORMAL FILL
    1 IF( ITRP.NE.0) GOTO 3
      IF( ICOMP.LT. IM1) GOTO 2
      CM( II1, JJ1)= G11
      CM( II1, JJ2)= G12
    2 IF( ICOMP.GE. IM2) GOTO 5
      CM( II2, JJ1)= G21
      CM( II2, JJ2)= G22
C     TRANSPOSED FILL
      GOTO 5
    3 IF( ICOMP.LT. IM1) GOTO 4
      CM( JJ1, II1)= G11
      CM( JJ2, II1)= G12
    4 IF( ICOMP.GE. IM2) GOTO 5
      CM( JJ1, II2)= G21
      CM( JJ2, II2)= G22
    5 CONTINUE
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE CMSW( J1, J2, I1, I2, CM, CW, NCW, NROW, ITRP)
C ***
      IMPLICIT REAL (A-H,O-Z)
C     COMPUTES MATRIX ELEMENTS FOR E ALONG WIRES DUE TO PATCH CURRENT
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CM, ZRATI, ZRATI2, T1, EXK, EYK, EZK, EXS, EYS, EZS,
     &EXC, EYC, EZC, EMEL, CW, FRATI
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ANGL/ SALP( NM)
      COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
     &KSYMP, IFAR, IPERF, T1, T2
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
     &NSCON, IPCON(10), NPCON
      DIMENSION  CAB(1), SAB(1), CM( NROW,1), CW( NROW,1)
      DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), EMEL(9
     &)
      EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
     &T2Z,ITAG),(CAB,ALP),(SAB,BET)
      EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
     &IND1),(T2ZJ,IND2)
      DATA   PI/3.141592654D+0/
      LDP= LD+1
      NEQS= N- N1+2*( M- M1)
      IF( ITRP.LT.0) GOTO 13
      K=0
C     OBSERVATION LOOP
      ICGO=1
      DO 12  I= I1, I2
      K= K+1
      XI= X( I)
      YI= Y( I)
      ZI= Z( I)
      CABI= CAB( I)
      SABI= SAB( I)
      SALPI= SALP( I)
      IPCH=0
      IF( ICON1( I).LT.10000) GOTO 1
      IPCH= ICON1( I)-10000
      FSIGN=-1.
    1 IF( ICON2( I).LT.10000) GOTO 2
      IPCH= ICON2( I)-10000
      FSIGN=1.
C     SOURCE LOOP
    2 JL=0
      DO 12  J= J1, J2
      JS= LDP- J
      JL= JL+2
      T1XJ= T1X( JS)
      T1YJ= T1Y( JS)
      T1ZJ= T1Z( JS)
      T2XJ= T2X( JS)
      T2YJ= T2Y( JS)
      T2ZJ= T2Z( JS)
      XJ= X( JS)
      YJ= Y( JS)
      ZJ= Z( JS)
C     GROUND LOOP
      S= BI( JS)
      DO 12  IP=1, KSYMP
      IPGND= IP
      IF( IPCH.NE. J.AND. ICGO.EQ.1) GOTO 9
      IF( IP.EQ.2) GOTO 9
      IF( ICGO.GT.1) GOTO 6
      CALL PCINT( XI, YI, ZI, CABI, SABI, SALPI, EMEL)
      PY= PI* SI( I)* FSIGN
      PX= SIN( PY)
      PY= COS( PY)
      EXC= EMEL(9)* FSIGN
      CALL TRIO( I)
      IF( I.GT. N1) GOTO 3
      IL= NEQS+ ICONX( I)
      GOTO 4
    3 IL= I- NCW
      IF( I.LE. NP) IL=(( IL-1)/ NP)*2* MP+ IL
    4 IF( ITRP.NE.0) GOTO 5
      CW( K, IL)= CW( K, IL)+ EXC*( AX( JSNO)+ BX( JSNO)* PX+ CX( JSNO)
     &* PY)
      GOTO 6
    5 CW( IL, K)= CW( IL, K)+ EXC*( AX( JSNO)+ BX( JSNO)* PX+ CX( JSNO)
     &* PY)
    6 IF( ITRP.NE.0) GOTO 7
      CM( K, JL-1)= EMEL( ICGO)
      CM( K, JL)= EMEL( ICGO+4)
      GOTO 8
    7 CM( JL-1, K)= EMEL( ICGO)
      CM( JL, K)= EMEL( ICGO+4)
    8 ICGO= ICGO+1
      IF( ICGO.EQ.5) ICGO=1
      GOTO 11
    9 CALL UNERE( XI, YI, ZI)
C     NORMAL FILL
      IF( ITRP.NE.0) GOTO 10
      CM( K, JL-1)= CM( K, JL-1)+ EXK* CABI+ EYK* SABI+ EZK* SALPI
      CM( K, JL)= CM( K, JL)+ EXS* CABI+ EYS* SABI+ EZS* SALPI
C     TRANSPOSED FILL
      GOTO 11
   10 CM( JL-1, K)= CM( JL-1, K)+ EXK* CABI+ EYK* SABI+ EZK* SALPI
      CM( JL, K)= CM( JL, K)+ EXS* CABI+ EYS* SABI+ EZS* SALPI
   11 CONTINUE
   12 CONTINUE
C     FOR OLD SEG. CONNECTING TO OLD PATCH ON ONE END AND NEW SEG. ON
C     OTHER END INTEGRATE SINGULAR COMPONENT (9) OF SURFACE CURRENT ONLY
      RETURN
   13 IF( J1.LT. I1.OR. J1.GT. I2) GOTO 16
      IPCH= ICON1( J1)
      IF( IPCH.LT.10000) GOTO 14
      IPCH= IPCH-10000
      FSIGN=-1.
      GOTO 15
   14 IPCH= ICON2( J1)
      IF( IPCH.LT.10000) GOTO 16
      IPCH= IPCH-10000
      FSIGN=1.
   15 IF( IPCH.GT. M1) GOTO 16
      JS= LDP- IPCH
      IPGND=1
      T1XJ= T1X( JS)
      T1YJ= T1Y( JS)
      T1ZJ= T1Z( JS)
      T2XJ= T2X( JS)
      T2YJ= T2Y( JS)
      T2ZJ= T2Z( JS)
      XJ= X( JS)
      YJ= Y( JS)
      ZJ= Z( JS)
      S= BI( JS)
      XI= X( J1)
      YI= Y( J1)
      ZI= Z( J1)
      CABI= CAB( J1)
      SABI= SAB( J1)
      SALPI= SALP( J1)
      CALL PCINT( XI, YI, ZI, CABI, SABI, SALPI, EMEL)
      PY= PI* SI( J1)* FSIGN
      PX= SIN( PY)
      PY= COS( PY)
      EXC= EMEL(9)* FSIGN
      IL= JCO( JSNO)
      K= J1- I1+1
      CW( K, IL)= CW( K, IL)+ EXC*( AX( JSNO)+ BX( JSNO)* PX+ CX( JSNO)
     &* PY)
   16 RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE CMWS( J, I1, I2, CM, NR, CW, NW, ITRP)
C ***
C
C     CMWS COMPUTES MATRIX ELEMENTS FOR WIRE-SURFACE INTERACTIONS
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CM, CW, ETK, ETS, ETC, EXK, EYK, EZK, EXS, EYS, EZS,
     &EXC, EYC, EZC
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ANGL/ SALP( NM)
      COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
     &NSCON, IPCON(10), NPCON
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      DIMENSION  CM( NR,1), CW( NW,1), CAB(1), SAB(1)
      DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
      EQUIVALENCE(CAB,ALP),(SAB,BET),(T1X,SI),(T1Y,ALP),(T1Z,BET)
      EQUIVALENCE(T2X,ICON1),(T2Y,ICON2),(T2Z,ITAG)
      LDP= LD+1
      S= SI( J)
      B= BI( J)
      XJ= X( J)
      YJ= Y( J)
      ZJ= Z( J)
      CABJ= CAB( J)
      SABJ= SAB( J)
C
C     OBSERVATION LOOP
C
      SALPJ= SALP( J)
      IPR=0
      DO 9  I= I1, I2
      IPR= IPR+1
      IPATCH=( I+1)/2
      IK= I-( I/2)*2
      IF( IK.EQ.0.AND. IPR.NE.1) GOTO 1
      JS= LDP- IPATCH
      XI= X( JS)
      YI= Y( JS)
      ZI= Z( JS)
      CALL HSFLD( XI, YI, ZI,0.)
      IF( IK.EQ.0) GOTO 1
      TX= T2X( JS)
      TY= T2Y( JS)
      TZ= T2Z( JS)
      GOTO 2
    1 TX= T1X( JS)
      TY= T1Y( JS)
      TZ= T1Z( JS)
    2 ETK=-( EXK* TX+ EYK* TY+ EZK* TZ)* SALP( JS)
      ETS=-( EXS* TX+ EYS* TY+ EZS* TZ)* SALP( JS)
C
C     FILL MATRIX ELEMENTS.  ELEMENT LOCATIONS DETERMINED BY CONNECTION
C     DATA.
C
      ETC=-( EXC* TX+ EYC* TY+ EZC* TZ)* SALP( JS)
C     NORMAL FILL
      IF( ITRP.NE.0) GOTO 4
      DO 3  IJ=1, JSNO
      JX= JCO( IJ)
    3 CM( IPR, JX)= CM( IPR, JX)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
     &IJ)
      GOTO 9
C     TRANSPOSED FILL
    4 IF( ITRP.EQ.2) GOTO 6
      DO 5  IJ=1, JSNO
      JX= JCO( IJ)
    5 CM( JX, IPR)= CM( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
     &IJ)
C     TRANSPOSED FILL - C(WS) AND D(WS)PRIME (=CW)
      GOTO 9
    6 DO 8  IJ=1, JSNO
      JX= JCO( IJ)
      IF( JX.GT. NR) GOTO 7
      CM( JX, IPR)= CM( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
     &IJ)
      GOTO 8
    7 JX= JX- NR
      CW( JX, IPR)= CW( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
     &IJ)
    8 CONTINUE
    9 CONTINUE
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE CMWW( J, I1, I2, CM, NR, CW, NW, ITRP)
C ***
      IMPLICIT REAL (A-H,O-Z)
C
C     CMWW COMPUTES MATRIX ELEMENTS FOR WIRE-WIRE INTERACTIONS
C
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CM, CW, ETK, ETS, ETC, EXK, EYK, EZK, EXS, EYS, EZS,
     &EXC, EYC, EZC
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ANGL/ SALP( NM)
      COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
     &NSCON, IPCON(10), NPCON
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      DIMENSION  CM( NR,1), CW( NW,1), CAB(1), SAB(1)
C     SET SOURCE SEGMENT PARAMETERS
      EQUIVALENCE(CAB,ALP),(SAB,BET)
      S= SI( J)
      B= BI( J)
      XJ= X( J)
      YJ= Y( J)
      ZJ= Z( J)
      CABJ= CAB( J)
      SABJ= SAB( J)
      SALPJ= SALP( J)
C     DECIDE WETHER EXT. T.W. APPROX. CAN BE USED
      IF( IEXK.EQ.0) GOTO 16
      IPR= ICON1( J)
      IF( IPR) 1,6,2
    1 IPR=- IPR
      IF(- ICON1( IPR).NE. J) GOTO 7
      GOTO 4
    2 IF( IPR.NE. J) GOTO 3
      IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 7
      GOTO 5
    3 IF( ICON2( IPR).NE. J) GOTO 7
    4 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
      IF( XI.LT.0.999999D+0) GOTO 7
      IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 7
    5 IND1=0
      GOTO 8
    6 IND1=1
      GOTO 8
    7 IND1=2
    8 IPR= ICON2( J)
      IF( IPR) 9,14,10
    9 IPR=- IPR
      IF(- ICON2( IPR).NE. J) GOTO 15
      GOTO 12
   10 IF( IPR.NE. J) GOTO 11
      IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 15
      GOTO 13
   11 IF( ICON1( IPR).NE. J) GOTO 15
   12 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
      IF( XI.LT.0.999999D+0) GOTO 15
      IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 15
   13 IND2=0
      GOTO 16
   14 IND2=1
      GOTO 16
   15 IND2=2
C
C     OBSERVATION LOOP
C
   16 CONTINUE
      IPR=0
      DO 23  I= I1, I2
      IPR= IPR+1
      IJ= I- J
      XI= X( I)
      YI= Y( I)
      ZI= Z( I)
      AI= BI( I)
      CABI= CAB( I)
      SABI= SAB( I)
      SALPI= SALP( I)
      CALL EFLD( XI, YI, ZI, AI, IJ)
      ETK= EXK* CABI+ EYK* SABI+ EZK* SALPI
      ETS= EXS* CABI+ EYS* SABI+ EZS* SALPI
C
C     FILL MATRIX ELEMENTS.  ELEMENT LOCATIONS DETERMINED BY CONNECTION
C     DATA.
C
      ETC= EXC* CABI+ EYC* SABI+ EZC* SALPI
C     NORMAL FILL
      IF( ITRP.NE.0) GOTO 18
      DO 17  IJ=1, JSNO
      JX= JCO( IJ)
   17 CM( IPR, JX)= CM( IPR, JX)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
     &IJ)
      GOTO 23
C     TRANSPOSED FILL
   18 IF( ITRP.EQ.2) GOTO 20
      DO 19  IJ=1, JSNO
      JX= JCO( IJ)
   19 CM( JX, IPR)= CM( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
     &IJ)
C     TRANS. FILL FOR C(WW) - TEST FOR ELEMENTS FOR D(WW)PRIME.  (=CW)
      GOTO 23
   20 DO 22  IJ=1, JSNO
      JX= JCO( IJ)
      IF( JX.GT. NR) GOTO 21
      CM( JX, IPR)= CM( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
     &IJ)
      GOTO 22
   21 JX= JX- NR
      CW( JX, IPR)= CW( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX(
     &IJ)
   22 CONTINUE
   23 CONTINUE
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE CONECT( IGND)
C ***
      IMPLICIT REAL (A-H,O-Z)
C
C     CONNECT SETS UP SEGMENT CONNECTION DATA IN ARRAYS ICON1 AND ICON2
C     BY SEARCHING FOR SEGMENT ENDS THAT ARE IN CONTACT.
C
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
     &NSCON, IPCON(10), NPCON
      DIMENSION  X2(1), Y2(1), Z2(1)
      EQUIVALENCE(X2,SI),(Y2,ALP),(Z2,BET)
      DATA   JMAX/30/, SMIN/1.D-3/, NSMAX/50/, NPMAX/10/
      NSCON=0
      NPCON=0
      IF( IGND.EQ.0) GOTO 3
      WRITE( 6,54)
      IF( IGND.GT.0) WRITE( 6,55)
      IF( IPSYM.NE.2) GOTO 1
      NP=2* NP
      MP=2* MP
    1 IF( IABS( IPSYM).LE.2) GOTO 2
      NP= N
      MP= M
    2 IF( NP.GT. N) STOP
      IF( NP.EQ. N.AND. MP.EQ. M) IPSYM=0
    3 IF( N.EQ.0) GOTO 26
      DO 15  I=1, N
      ICONX( I)=0
      XI1= X( I)
      YI1= Y( I)
      ZI1= Z( I)
      XI2= X2( I)
      YI2= Y2( I)
      ZI2= Z2( I)
C
C     DETERMINE CONNECTION DATA FOR END 1 OF SEGMENT.
C
      SLEN= SQRT(( XI2- XI1)**2+( YI2- YI1)**2+( ZI2- ZI1)**2)* SMIN
      IF( IGND.LT.1) GOTO 5
      IF( ZI1.GT.- SLEN) GOTO 4
      WRITE( 6,56)  I
      STOP
    4 IF( ZI1.GT. SLEN) GOTO 5
      ICON1( I)= I
      Z( I)=0.
      GOTO 9
    5 IC= I
      DO 7  J=2, N
      IC= IC+1
      IF( IC.GT. N) IC=1
      SEP= ABS( XI1- X( IC))+ ABS( YI1- Y( IC))+ ABS( ZI1- Z( IC))
      IF( SEP.GT. SLEN) GOTO 6
      ICON1( I)=- IC
      GOTO 8
    6 SEP= ABS( XI1- X2( IC))+ ABS( YI1- Y2( IC))+ ABS( ZI1- Z2( IC))
      IF( SEP.GT. SLEN) GOTO 7
      ICON1( I)= IC
      GOTO 8
    7 CONTINUE
      IF( I.LT. N2.AND. ICON1( I).GT.10000) GOTO 8
C
C     DETERMINE CONNECTION DATA FOR END 2 OF SEGMENT.
C
      ICON1( I)=0
    8 IF( IGND.LT.1) GOTO 12
    9 IF( ZI2.GT.- SLEN) GOTO 10
      WRITE( 6,56)  I
      STOP
   10 IF( ZI2.GT. SLEN) GOTO 12
      IF( ICON1( I).NE. I) GOTO 11
      WRITE( 6,57)  I
      STOP
   11 ICON2( I)= I
      Z2( I)=0.
      GOTO 15
   12 IC= I
      DO 14  J=2, N
      IC= IC+1
      IF( IC.GT. N) IC=1
      SEP= ABS( XI2- X( IC))+ ABS( YI2- Y( IC))+ ABS( ZI2- Z( IC))
      IF( SEP.GT. SLEN) GOTO 13
      ICON2( I)= IC
      GOTO 15
   13 SEP= ABS( XI2- X2( IC))+ ABS( YI2- Y2( IC))+ ABS( ZI2- Z2( IC))
      IF( SEP.GT. SLEN) GOTO 14
      ICON2( I)=- IC
      GOTO 15
   14 CONTINUE
      IF( I.LT. N2.AND. ICON2( I).GT.10000) GOTO 15
      ICON2( I)=0
   15 CONTINUE
C     FIND WIRE-SURFACE CONNECTIONS FOR NEW PATCHES
      IF( M.EQ.0) GOTO 26
      IX= LD+1- M1
      I= M2
   16 IF( I.GT. M) GOTO 20
      IX= IX-1
      XS= X( IX)
      YS= Y( IX)
      ZS= Z( IX)
      DO 18  ISEG=1, N
      XI1= X( ISEG)
      YI1= Y( ISEG)
      ZI1= Z( ISEG)
      XI2= X2( ISEG)
      YI2= Y2( ISEG)
      ZI2= Z2( ISEG)
C     FOR FIRST END OF SEGMENT
      SLEN=( ABS( XI2- XI1)+ ABS( YI2- YI1)+ ABS( ZI2- ZI1))* SMIN
      SEP= ABS( XI1- XS)+ ABS( YI1- YS)+ ABS( ZI1- ZS)
C     CONNECTION - DIVIDE PATCH INTO 4 PATCHES AT PRESENT ARRAY LOC.
      IF( SEP.GT. SLEN) GOTO 17
      ICON1( ISEG)=10000+ I
      IC=0
      CALL SUBPH( I, IC, XI1, YI1, ZI1, XI2, YI2, ZI2, XA, YA, ZA, XS,
     &YS, ZS)
      GOTO 19
   17 SEP= ABS( XI2- XS)+ ABS( YI2- YS)+ ABS( ZI2- ZS)
      IF( SEP.GT. SLEN) GOTO 18
      ICON2( ISEG)=10000+ I
      IC=0
      CALL SUBPH( I, IC, XI1, YI1, ZI1, XI2, YI2, ZI2, XA, YA, ZA, XS,
     &YS, ZS)
      GOTO 19
   18 CONTINUE
   19 I= I+1
C     REPEAT SEARCH FOR NEW SEGMENTS CONNECTED TO NGF PATCHES.
      GOTO 16
   20 IF( M1.EQ.0.OR. N2.GT. N) GOTO 26
      IX= LD+1
      I=1
   21 IF( I.GT. M1) GOTO 25
      IX= IX-1
      XS= X( IX)
      YS= Y( IX)
      ZS= Z( IX)
      DO 23  ISEG= N2, N
      XI1= X( ISEG)
      YI1= Y( ISEG)
      ZI1= Z( ISEG)
      XI2= X2( ISEG)
      YI2= Y2( ISEG)
      ZI2= Z2( ISEG)
      SLEN=( ABS( XI2- XI1)+ ABS( YI2- YI1)+ ABS( ZI2- ZI1))* SMIN
      SEP= ABS( XI1- XS)+ ABS( YI1- YS)+ ABS( ZI1- ZS)
      IF( SEP.GT. SLEN) GOTO 22
      ICON1( ISEG)=10001+ M
      IC=1
      NPCON= NPCON+1
      IPCON( NPCON)= I
      CALL SUBPH( I, IC, XI1, YI1, ZI1, XI2, YI2, ZI2, XA, YA, ZA, XS,
     &YS, ZS)
      GOTO 24
   22 SEP= ABS( XI2- XS)+ ABS( YI2- YS)+ ABS( ZI2- ZS)
      IF( SEP.GT. SLEN) GOTO 23
      ICON2( ISEG)=10001+ M
      IC=1
      NPCON= NPCON+1
      IPCON( NPCON)= I
      CALL SUBPH( I, IC, XI1, YI1, ZI1, XI2, YI2, ZI2, XA, YA, ZA, XS,
     &YS, ZS)
      GOTO 24
   23 CONTINUE
   24 I= I+1
      GOTO 21
   25 IF( NPCON.LE. NPMAX) GOTO 26
      WRITE( 6,62)  NPMAX
      STOP
   26 WRITE( 6,58)  N, NP, IPSYM
      IF( M.GT.0) WRITE( 6,61)  M, MP
      ISEG=( N+ M)/( NP+ MP)
      IF( ISEG.EQ.1) GOTO 30
      IF( IPSYM) 28,27,29
   27 STOP
   28 WRITE( 6,59)  ISEG
      GOTO 30
   29 IC= ISEG/2
      IF( ISEG.EQ.8) IC=3
      WRITE( 6,60)  IC
   30 IF( N.EQ.0) GOTO 48
      WRITE( 6,50)
C     ADJUST CONNECTED SEG. ENDS TO EXACTLY COINCIDE.  PRINT JUNCTIONS
C     OF 3 OR MORE SEG.  ALSO FIND OLD SEG. CONNECTING TO NEW SEG.
      ISEG=0
      DO 44  J=1, N
      IEND=-1
      JEND=-1
      IX= ICON1( J)
      IC=1
      JCO(1)=- J
      XA= X( J)
      YA= Y( J)
      ZA= Z( J)
   31 IF( IX.EQ.0) GOTO 43
      IF( IX.EQ. J) GOTO 43
      IF( IX.GT.10000) GOTO 43
      NSFLG=0
   32 IF( IX) 33,49,34
   33 IX=- IX
      GOTO 35
   34 JEND=- JEND
   35 IF( IX.EQ. J) GOTO 37
      IF( IX.LT. J) GOTO 43
      IC= IC+1
      IF( IC.GT. JMAX) GOTO 49
      JCO( IC)= IX* JEND
      IF( IX.GT. N1) NSFLG=1
      IF( JEND.EQ.1) GOTO 36
      XA= XA+ X( IX)
      YA= YA+ Y( IX)
      ZA= ZA+ Z( IX)
      IX= ICON1( IX)
      GOTO 32
   36 XA= XA+ X2( IX)
      YA= YA+ Y2( IX)
      ZA= ZA+ Z2( IX)
      IX= ICON2( IX)
      GOTO 32
   37 SEP= IC
      XA= XA/ SEP
      YA= YA/ SEP
      ZA= ZA/ SEP
      DO 39  I=1, IC
      IX= JCO( I)
      IF( IX.GT.0) GOTO 38
      IX=- IX
      X( IX)= XA
      Y( IX)= YA
      Z( IX)= ZA
      GOTO 39
   38 X2( IX)= XA
      Y2( IX)= YA
      Z2( IX)= ZA
   39 CONTINUE
      IF( N1.EQ.0) GOTO 42
      IF( NSFLG.EQ.0) GOTO 42
      DO 41  I=1, IC
      IX= IABS( JCO( I))
      IF( IX.GT. N1) GOTO 41
      IF( ICONX( IX).NE.0) GOTO 41
      NSCON= NSCON+1
      IF( NSCON.LE. NSMAX) GOTO 40
      WRITE( 6,62)  NSMAX
      STOP
   40 ISCON( NSCON)= IX
      ICONX( IX)= NSCON
   41 CONTINUE
   42 IF( IC.LT.3) GOTO 43
      ISEG= ISEG+1
      WRITE( 6,51)  ISEG,( JCO( I), I=1, IC)
   43 IF( IEND.EQ.1) GOTO 44
      IEND=1
      JEND=1
      IX= ICON2( J)
      IC=1
      JCO(1)= J
      XA= X2( J)
      YA= Y2( J)
      ZA= Z2( J)
      GOTO 31
   44 CONTINUE
      IF( ISEG.EQ.0) WRITE( 6,52)
C     FIND OLD SEGMENTS THAT CONNECT TO NEW PATCHES
      IF( N1.EQ.0.OR. M1.EQ. M) GOTO 48
      DO 47  J=1, N1
      IX= ICON1( J)
      IF( IX.LT.10000) GOTO 45
      IX= IX-10000
      IF( IX.GT. M1) GOTO 46
   45 IX= ICON2( J)
      IF( IX.LT.10000) GOTO 47
      IX= IX-10000
      IF( IX.LT. M2) GOTO 47
   46 IF( ICONX( J).NE.0) GOTO 47
      NSCON= NSCON+1
      ISCON( NSCON)= J
      ICONX( J)= NSCON
   47 CONTINUE
   48 CONTINUE
      RETURN
   49 WRITE( 6,53)  IX
C
      STOP
   50 FORMAT(//,9X,'- MULTIPLE WIRE JUNCTIONS -',/,1X,'JUNCTION',4X,
     &'SEGMENTS  (- FOR END 1, + FOR END 2)')
   51 FORMAT(1X,I5,5X,20I5,/,(11X,20I5))
   52 FORMAT(2X,'NONE')
   53 FORMAT(' CONNECT - SEGMENT CONNECTION ERROR FOR SEGMENT',I5)
   54 FORMAT(/,3X,'GROUND PLANE SPECIFIED.')
   55 FORMAT(/,3X,'WHERE WIRE ENDS TOUCH GROUND, CURRENT WILL BE ',
     &'INTERPOLATED TO IMAGE IN GROUND PLANE.',/)
   56 FORMAT(' GEOMETRY DATA ERROR-- SEGMENT',I5,' EXTENDS BELOW GRO',
     &'UND')
   57 FORMAT(' GEOMETRY DATA ERROR--SEGMENT',I5,' LIES IN GROUND ',
     &'PLANE.')
   58 FORMAT(/,3X,'TOTAL SEGMENTS USED=',I5,5X,'NO. SEG. IN ','A SY',
     &'MMETRIC CELL=',I5,5X,'SYMMETRY FLAG=',I3)
   59 FORMAT(' STRUCTURE HAS',I4,' FOLD ROTATIONAL SYMMETRY',/)
   60 FORMAT(' STRUCTURE HAS',I2,' PLANES OF SYMMETRY',/)
   61 FORMAT(3X,'TOTAL PATCHES USED=',I5,6X,'NO. PATCHES IN A SYMMET',
     &'RIC CELL=',I5)
   62 FORMAT(' ERROR - NO. NEW SEGMENTS CONNECTED TO N.G.F. SEGMENTS',
     &'OR PATCHES EXCEEDS LIMIT OF',I5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE COUPLE( CUR, WLAM)
C ***
      IMPLICIT REAL (A-H,O-Z)
C
C     COUPLE COMPUTES THE MAXIMUM COUPLING BETWEEN PAIRS OF SEGMENTS.
C
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  Y11A, Y12A, CUR, Y11, Y12, Y22, YL, YIN, ZL, ZIN, RHO
     &, VQD, VSANT, VQDS
      COMMON  /YPARM/ NCOUP, ICOUP, NCTAG(5), NCSEG(5), Y11A(5), Y12A(
     &20)
      COMMON  /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
     &, IQDS(30), NVQD, NSANT, NQDS
      DIMENSION  CUR(1)
      IF( NSANT.NE.1.OR. NVQD.NE.0) RETURN
      J= ISEGNO( NCTAG( ICOUP+1), NCSEG( ICOUP+1))
      IF( J.NE. ISANT(1)) RETURN
      ICOUP= ICOUP+1
      ZIN= VSANT(1)
      Y11A( ICOUP)= CUR( J)* WLAM/ ZIN
      L1=( ICOUP-1)*( NCOUP-1)
      DO 1  I=1, NCOUP
      IF( I.EQ. ICOUP) GOTO 1
      K= ISEGNO( NCTAG( I), NCSEG( I))
      L1= L1+1
      Y12A( L1)= CUR( K)* WLAM/ ZIN
    1 CONTINUE
      IF( ICOUP.LT. NCOUP) RETURN
      WRITE( 6,6)
      NPM1= NCOUP-1
      DO 5  I=1, NPM1
      ITT1= NCTAG( I)
      ITS1= NCSEG( I)
      ISG1= ISEGNO( ITT1, ITS1)
      L1= I+1
      DO 5  J= L1, NCOUP
      ITT2= NCTAG( J)
      ITS2= NCSEG( J)
      ISG2= ISEGNO( ITT2, ITS2)
      J1= J+( I-1)* NPM1-1
      J2= I+( J-1)* NPM1
      Y11= Y11A( I)
      Y22= Y11A( J)
      Y12=.5*( Y12A( J1)+ Y12A( J2))
      YIN= Y12* Y12
      DBC= ABS( YIN)
      C= DBC/(2.* REAL( Y11)* REAL( Y22)- REAL( YIN))
      IF( C.LT.0..OR. C.GT.1.) GOTO 4
      IF( C.LT..01) GOTO 2
      GMAX=(1.- SQRT(1.- C* C))/ C
      GOTO 3
    2 GMAX=.5*( C+.25* C* C* C)
    3 RHO= GMAX* CONJG( YIN)/ DBC
      YL=((1.- RHO)/(1.+ RHO)+1.)* REAL( Y22)- Y22
      ZL=1./ YL
      YIN= Y11- YIN/( Y22+ YL)
      ZIN=1./ YIN
      DBC= DB10( GMAX)
      WRITE( 6,7)  ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, DBC, ZL, ZIN
      GOTO 5
    4 WRITE( 6,8)  ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, C
    5 CONTINUE
C
      RETURN
    6 FORMAT(///,36X,'- - - ISOLATION DATA - - -',//,6X,'- - COUPLIN',
     &'G BETWEEN - -',8X,'MAXIMUM',15X,'- - - FOR MAXIMUM COUPLING - ',
     &'- -',/,12X,'SEG.',14X,'SEG.',3X,'COUPLING',4X,'LOAD IMPEDANCE ',
     &'(2ND SEG.)',7X,'INPUT IMPEDANCE',/,2X,'TAG/SEG.',3X,'NO.',4X,
     &'TAG/''SEG.',3X,'NO.',6X,'(DB)',8X,'REAL',9X,'IMAG.',9X,'REAL',9X
     &,'IMAG.')
    7 FORMAT(2(1X,I4,1X,I4,1X,I5,2X),F9.3,2X,1P,2(2X,E12.5,1X,E12.5))
    8 FORMAT(2(1X,I4,1X,I4,1X,I5,2X),'**ERROR** COUPLING IS NOT BETWE',
     &'EN 0 AND 1. (=',1P,E12.5,')')
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE DATAGN
C ***
      IMPLICIT REAL (A-H,O-Z)
C
C     DATAGN IS THE MAIN ROUTINE FOR INPUT OF GEOMETRY DATA.
C
C***
      PARAMETER ( NM=600, N2M=800, N3M=1000)
C***
      CHARACTER *2  GM, ATST
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
C***
      COMMON  /ANGL/ SALP( NM)
C***
      COMMON  /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4
      DIMENSION  X2(1), Y2(1), Z2(1), T1X(1), T1Y(1), T1Z(1), T2X(1),
     &T2Y(1), T2Z(1), ATST(13), IFX(2), IFY(2), IFZ(2), CAB(1), SAB(1),
     & IPT(4)
C***
      EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
     &T2Z,ITAG),(X2,SI),(Y2,ALP),(Z2,BET),(CAB,ALP),(SAB,BET)
C***
      data atst/'GW','GX','GR','GS','GE','GM','SP','SM','GF','GA',
     $          'SC','GC','GH'/
*      DATA   ATST/2HGW,2HGX,2HGR,2HGS,2HGE,2HGM,2HSP,2HSM,2HGF,2HGA,
*     &2HSC,2HGC,2HGH/
      DATA   IFX/1H ,1HX/, IFY/1H ,1HY/, IFZ/1H ,1HZ/
      DATA   TA/0.01745329252D+0/, TD/57.29577951D+0/, IPT/1HP,1HR,1HT,
     &1HQ/
      IPSYM=0
      NWIRE=0
      N=0
      NP=0
      M=0
      MP=0
      N1=0
      N2=1
      M1=0
      M2=1
      ISCT=0
C
C     READ GEOMETRY DATA CARD AND BRANCH TO SECTION FOR OPERATION
C     REQUESTED
C
C***
C 1     READ (5,42) GM,ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD
      IPHD=0
C***
    1 CALL READGM( GM, ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD)
      IF( N+ M.GT. LD) GOTO 37
      IF( GM.EQ. ATST(9)) GOTO 27
      IF( IPHD.EQ.1) GOTO 2
      WRITE( 6,40)
      WRITE( 6,41)
      IPHD=1
    2 IF( GM.EQ. ATST(11)) GOTO 10
      ISCT=0
      IF( GM.EQ. ATST(1)) GOTO 3
      IF( GM.EQ. ATST(2)) GOTO 18
      IF( GM.EQ. ATST(3)) GOTO 19
      IF( GM.EQ. ATST(4)) GOTO 21
      IF( GM.EQ. ATST(7)) GOTO 9
      IF( GM.EQ. ATST(8)) GOTO 13
      IF( GM.EQ. ATST(5)) GOTO 29
      IF( GM.EQ. ATST(6)) GOTO 26
C***
      IF( GM.EQ. ATST(10)) GOTO 8
C***
      IF( GM.EQ. ATST(13)) GOTO 123
C
C     GENERATE SEGMENT DATA FOR STRAIGHT WIRE.
C
      GOTO 36
    3 NWIRE= NWIRE+1
      I1= N+1
      I2= N+ NS
      WRITE( 6,43)  NWIRE, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, NS, I1,
     &I2, ITG
      IF( RAD.EQ.0) GOTO 4
      XS1=1.
      YS1=1.
C***
      GOTO 7
C 4     READ (5,42) GM,IX,IY,XS1,YS1,ZS1
C***
    4 CALL READGM( GM, IX, IY, XS1, YS1, ZS1, DUMMY, DUMMY, DUMMY,
     &DUMMY)
      IF( GM.EQ. ATST(12)) GOTO 6
    5 WRITE( 6,48)
      STOP
    6 WRITE( 6,61)  XS1, YS1, ZS1
      IF( YS1.EQ.0.OR. ZS1.EQ.0) GOTO 5
      RAD= YS1
      YS1=( ZS1/ YS1)**(1./( NS-1.))
    7 CALL WIRE( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, XS1, YS1, NS, ITG)
C
C     GENERATE SEGMENT DATA FOR WIRE ARC
C
      GOTO 1
    8 NWIRE= NWIRE+1
      I1= N+1
      I2= N+ NS
      WRITE( 6,38)  NWIRE, XW1, YW1, ZW1, XW2, NS, I1, I2, ITG
      CALL ARC( ITG, NS, XW1, YW1, ZW1, XW2)
C***
C
C     GENERATE HELIX
C
      GOTO 1
  123 NWIRE= NWIRE+1
      I1= N+1
      I2= N+ NS
      WRITE( 6,124)  XW1, YW1, NWIRE, ZW1, XW2, YW2, ZW2, RAD, NS, I1,
     &I2, ITG
      CALL HELIX( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, NS, ITG)
C
      GOTO 1
C***
C
C     GENERATE SINGLE NEW PATCH
C
  124 FORMAT(5X,'HELIX STRUCTURE-   AXIAL SPACING BETWEEN TURNS =',F8.3
     &,' TOTAL AXIAL LENGTH =',F8.3/1X,I5,2X,'RADIUS OF HELIX =',4(2X,F
     &8.3),7X,F11.5,I8,4X,I5,1X,I5,3X,I5)
    9 I1= M+1
      NS= NS+1
      IF( ITG.NE.0) GOTO 17
      WRITE( 6,51)  I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2
      IF( NS.EQ.2.OR. NS.EQ.4) ISCT=1
      IF( NS.GT.1) GOTO 14
      XW2= XW2* TA
      YW2= YW2* TA
      GOTO 16
   10 IF( ISCT.EQ.0) GOTO 17
      I1= M+1
      NS= NS+1
      IF( ITG.NE.0) GOTO 17
      IF( NS.NE.2.AND. NS.NE.4) GOTO 17
      XS1= X4
      YS1= Y4
      ZS1= Z4
      XS2= X3
      YS2= Y3
      ZS2= Z3
      X3= XW1
      Y3= YW1
      Z3= ZW1
      IF( NS.NE.4) GOTO 11
      X4= XW2
      Y4= YW2
      Z4= ZW2
   11 XW1= XS1
      YW1= YS1
      ZW1= ZS1
      XW2= XS2
      YW2= YS2
      ZW2= ZS2
      IF( NS.EQ.4) GOTO 12
      X4= XW1+ X3- XW2
      Y4= YW1+ Y3- YW2
      Z4= ZW1+ Z3- ZW2
   12 WRITE( 6,51)  I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2
      WRITE( 6,39)  X3, Y3, Z3, X4, Y4, Z4
C
C     GENERATE MULTIPLE-PATCH SURFACE
C
      GOTO 16
   13 I1= M+1
      WRITE( 6,59)  I1, IPT(2), XW1, YW1, ZW1, XW2, YW2, ZW2, ITG, NS
C***
      IF( ITG.LT.1.OR. NS.LT.1) GOTO 17
C 14    READ (5,42) GM,IX,IY,X3,Y3,Z3,X4,Y4,Z4
C***
   14 CALL READGM( GM, IX, IY, X3, Y3, Z3, X4, Y4, Z4, DUMMY)
      IF( NS.NE.2.AND. ITG.LT.1) GOTO 15
      X4= XW1+ X3- XW2
      Y4= YW1+ Y3- YW2
      Z4= ZW1+ Z3- ZW2
   15 WRITE( 6,39)  X3, Y3, Z3, X4, Y4, Z4
      IF( GM.NE. ATST(11)) GOTO 17
   16 CALL PATCH( ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, X3, Y3, Z3, X4
     &, Y4, Z4)
      GOTO 1
   17 WRITE( 6,60)
C
C     REFLECT STRUCTURE ALONG X,Y, OR Z AXES OR ROTATE TO FORM CYLINDER.
C
      STOP
   18 IY= NS/10
      IZ= NS- IY*10
      IX= IY/10
      IY= IY- IX*10
      IF( IX.NE.0) IX=1
      IF( IY.NE.0) IY=1
      IF( IZ.NE.0) IZ=1
      WRITE( 6,44)  IFX( IX+1), IFY( IY+1), IFZ( IZ+1), ITG
      GOTO 20
   19 WRITE( 6,45)  NS, ITG
      IX=-1
   20 CALL REFLC( IX, IY, IZ, ITG, NS)
C
C     SCALE STRUCTURE DIMENSIONS BY FACTOR XW1.
C
      GOTO 1
   21 IF( N.LT. N2) GOTO 23
      DO 22  I= N2, N
      X( I)= X( I)* XW1
      Y( I)= Y( I)* XW1
      Z( I)= Z( I)* XW1
      X2( I)= X2( I)* XW1
      Y2( I)= Y2( I)* XW1
      Z2( I)= Z2( I)* XW1
   22 BI( I)= BI( I)* XW1
   23 IF( M.LT. M2) GOTO 25
      YW1= XW1* XW1
      IX= LD+1- M
      IY= LD- M1
      DO 24  I= IX, IY
      X( I)= X( I)* XW1
      Y( I)= Y( I)* XW1
      Z( I)= Z( I)* XW1
   24 BI( I)= BI( I)* YW1
   25 WRITE( 6,46)  XW1
C
C     MOVE STRUCTURE OR REPRODUCE ORIGINAL STRUCTURE IN NEW POSITIONS.
C
      GOTO 1
   26 WRITE( 6,47)  ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD
      XW1= XW1* TA
      YW1= YW1* TA
      ZW1= ZW1* TA
      CALL MOVE( XW1, YW1, ZW1, XW2, YW2, ZW2, INT( RAD+.5), NS, ITG)
C
C     READ NUMERICAL GREEN'S FUNCTION TAPE
C
      GOTO 1
   27 IF( N+ M.EQ.0) GOTO 28
      WRITE( 6,52)
      STOP
   28 CALL GFIL( ITG)
      NPSAV= NP
      MPSAV= MP
      IPSAV= IPSYM
C
C     TERMINATE STRUCTURE GEOMETRY INPUT.
C
C***
      GOTO 1
   29 IF( NS.EQ.0) GOTO 290
      IPLP1=1
      IPLP2=1
C***
  290 IX= N1+ M1
      IF( IX.EQ.0) GOTO 30
      NP= N
      MP= M
      IPSYM=0
   30 CALL CONECT( ITG)
      IF( IX.EQ.0) GOTO 31
      NP= NPSAV
      MP= MPSAV
      IPSYM= IPSAV
   31 IF( N+ M.GT. LD) GOTO 37
      IF( N.EQ.0) GOTO 33
      WRITE( 6,53)
      WRITE( 6,54)
      DO 32  I=1, N
      XW1= X2( I)- X( I)
      YW1= Y2( I)- Y( I)
      ZW1= Z2( I)- Z( I)
      X( I)=( X( I)+ X2( I))*.5
      Y( I)=( Y( I)+ Y2( I))*.5
      Z( I)=( Z( I)+ Z2( I))*.5
      XW2= XW1* XW1+ YW1* YW1+ ZW1* ZW1
      YW2= SQRT( XW2)
      YW2=( XW2/ YW2+ YW2)*.5
      SI( I)= YW2
      CAB( I)= XW1/ YW2
      SAB( I)= YW1/ YW2
      XW2= ZW1/ YW2
      IF( XW2.GT.1.) XW2=1.
      IF( XW2.LT.-1.) XW2=-1.
      SALP( I)= XW2
      XW2= ASIN( XW2)* TD
      YW2= ATGN2( YW1, XW1)* TD
C***
      WRITE( 6,55)  I, X( I), Y( I), Z( I), SI( I), XW2, YW2, BI( I),
     &ICON1( I), I, ICON2( I), ITAG( I)
      IF( IPLP1.NE.1) GOTO 320
      WRITE( 8,*)  X( I), Y( I), Z( I), SI( I), XW2, YW2, BI( I), ICON1
     &( I), I, ICON2( I)
C***
  320 CONTINUE
      IF( SI( I).GT.1.D-20.AND. BI( I).GT.0.) GOTO 32
      WRITE( 6,56)
      STOP
   32 CONTINUE
   33 IF( M.EQ.0) GOTO 35
      WRITE( 6,57)
      J= LD+1
      DO 34  I=1, M
      J= J-1
      XW1=( T1Y( J)* T2Z( J)- T1Z( J)* T2Y( J))* SALP( J)
      YW1=( T1Z( J)* T2X( J)- T1X( J)* T2Z( J))* SALP( J)
      ZW1=( T1X( J)* T2Y( J)- T1Y( J)* T2X( J))* SALP( J)
      WRITE( 6,58)  I, X( J), Y( J), Z( J), XW1, YW1, ZW1, BI( J), T1X(
     & J), T1Y( J), T1Z( J), T2X( J), T2Y( J), T2Z( J)
   34 CONTINUE
   35 RETURN
   36 WRITE( 6,48)
      WRITE( 6,49)  GM, ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD
      STOP
   37 WRITE( 6,50)
C
      STOP
   38 FORMAT(1X,I5,2X,'ARC RADIUS =',F9.5,2X,'FROM',F8.3,' TO',F8.3,
     &' DEGREES',11X,F11.5,2X,I5,4X,I5,1X,I5,3X,I5)
   39 FORMAT(6X,3F11.5,1X,3F11.5)
   40 FORMAT(////,33X,'- - - STRUCTURE SPECIFICATION - - -',//,37X,
     &'COORDINATES MUST BE INPUT IN',/,37X,
     &'METERS OR BE SCALED TO METERS',/,37X,
     &'BEFORE STRUCTURE INPUT IS ENDED',//)
   41 FORMAT(2X,'WIRE',79X,'NO. OF',4X,'FIRST',2X,'LAST',5X,'TAG',/,2X,
     &'NO.',8X,'X1',9X,'Y1',9X,'Z1',10X,'X2',9X,'Y2',9X,'Z2',6X,
     &'RADIUS',3X,'SEG.',5X,'SEG.',3X,'SEG.',5X,'NO.')
   42 FORMAT(A2, I3, I5, 7F10.5)
   43 FORMAT(1X,I5,3F11.5,1X,4F11.5,2X,I5,4X,I5,1X,I5,3X,I5)
   44 FORMAT(6X,'STRUCTURE REFLECTED ALONG THE AXES',3(1X,A1),'.  TA',
     &'GS INCREMENTED BY',I5)
   45 FORMAT(6X,'STRUCTURE ROTATED ABOUT Z-AXIS',I3,' TIMES.  LABELS',
     &' INCREMENTED BY',I5)
   46 FORMAT(6X,'STRUCTURE SCALED BY FACTOR',F10.5)
   47 FORMAT(6X,'THE STRUCTURE HAS BEEN MOVED, MOVE DATA CARD IS -/6X',
     &I3,I5,7F10.5)
   48 FORMAT(' GEOMETRY DATA CARD ERROR')
   49 FORMAT(1X,A2,I3,I5,7F10.5)
   50 FORMAT(' NUMBER OF WIRE SEGMENTS AND SURFACE PATCHES EXCEEDS DI',
     &'MENSION LIMIT.')
   51 FORMAT(1X,I5,A1,F10.5,2F11.5,1X,3F11.5)
   52 FORMAT(' ERROR - GF MUST BE FIRST GEOMETRY DATA CARD')
   53 FORMAT(////33X,'- - - - SEGMENTATION DATA - - - -',//,40X,'COO',
     &'RDINATES IN METERS',//,25X,
     &'I+ AND I- INDICATE THE SEGMENTS BEFORE AND AFTER I',//)
   54 FORMAT(2X,'SEG.',3X,'COORDINATES OF SEG. CENTER',5X,'SEG.',5X,
     &'ORIENTATION ANGLES',4X,'WIRE',4X,'CONNECTION DATA',3X,'TAG',/,2X
     &,'NO.',7X,'X',9X,'Y',9X,'Z',7X,'LENGTH',5X,'ALPHA',5X,'BETA',6X,
     &'RADIUS',4X,'I-',3X,'I',4X,'I+',4X,'NO.')
   55 FORMAT(1X,I5,4F10.5,1X,3F10.5,1X,3I5,2X,I5)
   56 FORMAT(' SEGMENT DATA ERROR')
   57 FORMAT(////,44X,'- - - SURFACE PATCH DATA - - -',//,49X,'COORD',
     &'INATES IN METERS',//,1X,'PATCH',5X,'COORD. OF PATCH CENTER',7X,
     &'UNIT NORMAL VECTOR',6X,'PATCH',12X,
     &'COMPONENTS OF UNIT TANGENT V''ECTORS',/,2X,'NO.',6X,'X',9X,'Y',9
     &X,'Z',9X,'X',7X,'Y',7X,'Z',7X,'AREA',7X,'X1',6X,'Y1',6X,'Z1',7X,
     &'X2',6X,'Y2',6X,'Z2')
   58 FORMAT(1X,I4,3F10.5,1X,3F8.4,F10.5,1X,3F8.4,1X,3F8.4)
   59 FORMAT(1X,I5,A1,F10.5,2F11.5,1X,3F11.5,5X,'SURFACE -',I4,' BY',I3
     &,' PATCHES')
   60 FORMAT(' PATCH DATA ERROR')
   61 FORMAT(9X,'ABOVE WIRE IS TAPERED.  SEG. LENGTH RATIO =',F9.5,/,33
     &X,'RADIUS FROM',F9.5,' TO',F9.5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      FUNCTION DB10( X)
C ***
C
C     FUNCTION DB-- RETURNS DB FOR MAGNITUDE (FIELD) OR MAG**2 (POWER) I
C
      IMPLICIT REAL (A-H,O-Z)
      F=10.
      GOTO 1
      ENTRY DB20 (x)
      F=20.
    1 IF( X.LT.1.D-20) GOTO 2
      DB10= F* LOG10( X)
      RETURN
    2 DB10=-999.99
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE EFLD( XI, YI, ZI, AI, IJ)
C ***
      IMPLICIT REAL (A-H,O-Z)
C
C     COMPUTE NEAR E FIELDS OF A SEGMENT WITH SINE, COSINE, AND
C     CONSTANT CURRENTS.  GROUND EFFECT INCLUDED.
C
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  TXK, TYK, TZK, TXS, TYS, TZS, TXC, TYC, TZC, EXK, EYK
     &, EZK, EXS, EYS, EZS, EXC, EYC, EZC, EPX, EPY, ZRATI, REFS, REFPS
     &, ZRSIN, ZRATX, T1, ZSCRN, ZRATI2, TEZS, TERS, TEZC, TERC, TEZK,
     &TERK, EGND, FRATI
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
     &KSYMP, IFAR, IPERF, T1, T2
      COMMON  /INCOM/ XO, YO, ZO, SN, XSN, YSN, ISNOR
      DIMENSION  EGND(9)
      EQUIVALENCE(EGND(1),TXK),(EGND(2),TYK),(EGND(3),TZK),(EGND(4),TXS
     &),(EGND(5),TYS),(EGND(6),TZS),(EGND(7),TXC),(EGND(8),TYC),(EGND(9
     &),TZC)
      DATA   ETA/376.73/, PI/3.141592654D+0/, TP/6.283185308D+0/
      XIJ= XI- XJ
      YIJ= YI- YJ
      IJX= IJ
      RFL=-1.
      DO 12  IP=1, KSYMP
      IF( IP.EQ.2) IJX=1
      RFL=- RFL
      SALPR= SALPJ* RFL
      ZIJ= ZI- RFL* ZJ
      ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR
      RHOX= XIJ- CABJ* ZP
      RHOY= YIJ- SABJ* ZP
      RHOZ= ZIJ- SALPR* ZP
      RH= SQRT( RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ+ AI* AI)
      IF( RH.GT.1.D-10) GOTO 1
      RHOX=0.
      RHOY=0.
      RHOZ=0.
      GOTO 2
    1 RHOX= RHOX/ RH
      RHOY= RHOY/ RH
      RHOZ= RHOZ/ RH
    2 R= SQRT( ZP* ZP+ RH* RH)
C
C     LUMPED CURRENT ELEMENT APPROX. FOR LARGE SEPARATIONS
C
      IF( R.LT. RKH) GOTO 3
      RMAG= TP* R
      CTH= ZP/ R
      PX= RH/ R
      TXK= CMPLX( COS( RMAG),- SIN( RMAG))
      PY= TP* R* R
      TYK= ETA* CTH* TXK* CMPLX(1.D+0,-1.D+0/ RMAG)/ PY
      TZK= ETA* PX* TXK* CMPLX(1.D+0, RMAG-1.D+0/ RMAG)/(2.* PY)
      TEZK= TYK* CTH- TZK* PX
      TERK= TYK* PX+ TZK* CTH
      RMAG= SIN( PI* S)/ PI
      TEZC= TEZK* RMAG
      TERC= TERK* RMAG
      TEZK= TEZK* S
      TERK= TERK* S
      TXS=(0.,0.)
      TYS=(0.,0.)
      TZS=(0.,0.)
      GOTO 6
C
C     EKSC FOR THIN WIRE APPROX. OR EKSCX FOR EXTENDED T.W. APPROX.
C
    3 IF( IEXK.EQ.1) GOTO 4
      CALL EKSC( S, ZP, RH, TP, IJX, TEZS, TERS, TEZC, TERC, TEZK, TERK
     &)
      GOTO 5
    4 CALL EKSCX( B, S, ZP, RH, TP, IJX, IND1, IND2, TEZS, TERS, TEZC,
     &TERC, TEZK, TERK)
    5 TXS= TEZS* CABJ+ TERS* RHOX
      TYS= TEZS* SABJ+ TERS* RHOY
      TZS= TEZS* SALPR+ TERS* RHOZ
    6 TXK= TEZK* CABJ+ TERK* RHOX
      TYK= TEZK* SABJ+ TERK* RHOY
      TZK= TEZK* SALPR+ TERK* RHOZ
      TXC= TEZC* CABJ+ TERC* RHOX
      TYC= TEZC* SABJ+ TERC* RHOY
      TZC= TEZC* SALPR+ TERC* RHOZ
      IF( IP.NE.2) GOTO 11
      IF( IPERF.GT.0) GOTO 10
      ZRATX= ZRATI
      RMAG= R
C
C     SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN.
C
      XYMAG= SQRT( XIJ* XIJ+ YIJ* YIJ)
      IF( NRADL.EQ.0) GOTO 7
      XSPEC=( XI* ZJ+ ZI* XJ)/( ZI+ ZJ)
      YSPEC=( YI* ZJ+ ZI* YJ)/( ZI+ ZJ)
      RHOSPC= SQRT( XSPEC* XSPEC+ YSPEC* YSPEC+ T2* T2)
      IF( RHOSPC.GT. SCRWL) GOTO 7
      ZSCRN= T1* RHOSPC* LOG( RHOSPC/ T2)
      ZRATX=( ZSCRN* ZRATI)/( ETA* ZRATI+ ZSCRN)
C
C     CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED.
C
    7 IF( XYMAG.GT.1.D-6) GOTO 8
      PX=0.
      PY=0.
      CTH=1.
      ZRSIN=(1.,0.)
      GOTO 9
    8 PX=- YIJ/ XYMAG
      PY= XIJ/ XYMAG
      CTH= ZIJ/ RMAG
      ZRSIN= SQRT(1.- ZRATX* ZRATX*(1.- CTH* CTH))
    9 REFS=( CTH- ZRATX* ZRSIN)/( CTH+ ZRATX* ZRSIN)
      REFPS=-( ZRATX* CTH- ZRSIN)/( ZRATX* CTH+ ZRSIN)
      REFPS= REFPS- REFS
      EPY= PX* TXK+ PY* TYK
      EPX= PX* EPY
      EPY= PY* EPY
      TXK= REFS* TXK+ REFPS* EPX
      TYK= REFS* TYK+ REFPS* EPY
      TZK= REFS* TZK
      EPY= PX* TXS+ PY* TYS
      EPX= PX* EPY
      EPY= PY* EPY
      TXS= REFS* TXS+ REFPS* EPX
      TYS= REFS* TYS+ REFPS* EPY
      TZS= REFS* TZS
      EPY= PX* TXC+ PY* TYC
      EPX= PX* EPY
      EPY= PY* EPY
      TXC= REFS* TXC+ REFPS* EPX
      TYC= REFS* TYC+ REFPS* EPY
      TZC= REFS* TZC
   10 EXK= EXK- TXK* FRATI
      EYK= EYK- TYK* FRATI
      EZK= EZK- TZK* FRATI
      EXS= EXS- TXS* FRATI
      EYS= EYS- TYS* FRATI
      EZS= EZS- TZS* FRATI
      EXC= EXC- TXC* FRATI
      EYC= EYC- TYC* FRATI
      EZC= EZC- TZC* FRATI
      GOTO 12
   11 EXK= TXK
      EYK= TYK
      EZK= TZK
      EXS= TXS
      EYS= TYS
      EZS= TZS
      EXC= TXC
      EYC= TYC
      EZC= TZC
   12 CONTINUE
      IF( IPERF.EQ.2) GOTO 13
C
C     FIELD DUE TO GROUND USING SOMMERFELD/NORTON
C
      RETURN
   13 SN= SQRT( CABJ* CABJ+ SABJ* SABJ)
      IF( SN.LT.1.D-5) GOTO 14
      XSN= CABJ/ SN
      YSN= SABJ/ SN
      GOTO 15
   14 SN=0.
      XSN=1.
C
C     DISPLACE OBSERVATION POINT FOR THIN WIRE APPROXIMATION
C
      YSN=0.
   15 ZIJ= ZI+ ZJ
      SALPR=- SALPJ
      RHOX= SABJ* ZIJ- SALPR* YIJ
      RHOY= SALPR* XIJ- CABJ* ZIJ
      RHOZ= CABJ* YIJ- SABJ* XIJ
      RH= RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ
      IF( RH.GT.1.D-10) GOTO 16
      XO= XI- AI* YSN
      YO= YI+ AI* XSN
      ZO= ZI
      GOTO 17
   16 RH= AI/ SQRT( RH)
      IF( RHOZ.LT.0.) RH=- RH
      XO= XI+ RH* RHOX
      YO= YI+ RH* RHOY
      ZO= ZI+ RH* RHOZ
   17 R= XIJ* XIJ+ YIJ* YIJ+ ZIJ* ZIJ
C
C     FIELD FROM INTERPOLATION IS INTEGRATED OVER SEGMENT
C
      IF( R.GT..95) GOTO 18
      ISNOR=1
      DMIN= EXK* CONJG( EXK)+ EYK* CONJG( EYK)+ EZK* CONJG( EZK)
      DMIN=.01* SQRT( DMIN)
      SHAF=.5* S
      CALL ROM2(- SHAF, SHAF, EGND, DMIN)
C
C     NORTON FIELD EQUATIONS AND LUMPED CURRENT ELEMENT APPROXIMATION
C
      GOTO 19
   18 ISNOR=2
      CALL SFLDS(0., EGND)
      GOTO 22
   19 ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR
      RH= R- ZP* ZP
      IF( RH.GT.1.D-10) GOTO 20
      DMIN=0.
      GOTO 21
   20 DMIN= SQRT( RH/( RH+ AI* AI))
   21 IF( DMIN.GT..95) GOTO 22
      PX=1.- DMIN
      TERK=( TXK* CABJ+ TYK* SABJ+ TZK* SALPR)* PX
      TXK= DMIN* TXK+ TERK* CABJ
      TYK= DMIN* TYK+ TERK* SABJ
      TZK= DMIN* TZK+ TERK* SALPR
      TERS=( TXS* CABJ+ TYS* SABJ+ TZS* SALPR)* PX
      TXS= DMIN* TXS+ TERS* CABJ
      TYS= DMIN* TYS+ TERS* SABJ
      TZS= DMIN* TZS+ TERS* SALPR
      TERC=( TXC* CABJ+ TYC* SABJ+ TZC* SALPR)* PX
      TXC= DMIN* TXC+ TERC* CABJ
      TYC= DMIN* TYC+ TERC* SABJ
      TZC= DMIN* TZC+ TERC* SALPR
   22 EXK= EXK+ TXK
      EYK= EYK+ TYK
      EZK= EZK+ TZK
      EXS= EXS+ TXS
      EYS= EYS+ TYS
      EZS= EZS+ TZS
      EXC= EXC+ TXC
      EYC= EYC+ TYC
      EZC= EZC+ TZC
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE EKSC( S, Z, RH, XK, IJ, EZS, ERS, EZC, ERC, EZK, ERK)
C ***
      IMPLICIT REAL (A-H,O-Z)
C     COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
C     THIN WIRE APPROXIMATION.
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CON, GZ1, GZ2, GP1, GP2, GZP1, GZP2, EZS, ERS, EZC,
     &ERC, EZK, ERK
      COMMON  /TMI/ ZPK, RKB2, IJX
      DIMENSION  CONX(2)
      EQUIVALENCE(CONX,CON)
      DATA   CONX/0.,4.771341189D+0/
      IJX= IJ
      ZPK= XK* Z
      RHK= XK* RH
      RKB2= RHK* RHK
      SH=.5* S
      SHK= XK* SH
      SS= SIN( SHK)
      CS= COS( SHK)
      Z2= SH- Z
      Z1=-( SH+ Z)
      CALL GX( Z1, RH, XK, GZ1, GP1)
      CALL GX( Z2, RH, XK, GZ2, GP2)
      GZP1= GP1* Z1
      GZP2= GP2* Z2
      EZS= CON*(( GZ2- GZ1)* CS* XK-( GZP2+ GZP1)* SS)
      EZC=- CON*(( GZ2+ GZ1)* SS* XK+( GZP2- GZP1)* CS)
      ERK= CON*( GP2- GP1)* RH
      CALL INTX(- SHK, SHK, RHK, IJ, CINT, SINT)
      EZK=- CON*( GZP2- GZP1+ XK* XK* CMPLX( CINT,- SINT))
      GZP1= GZP1* Z1
      GZP2= GZP2* Z2
      IF( RH.LT.1.D-10) GOTO 1
      ERS=- CON*(( GZP2+ GZP1+ GZ2+ GZ1)* SS-( Z2* GZ2- Z1* GZ1)* CS*
     &XK)/ RH
      ERC=- CON*(( GZP2- GZP1+ GZ2- GZ1)* CS+( Z2* GZ2+ Z1* GZ1)* SS*
     &XK)/ RH
      RETURN
    1 ERS=(0.,0.)
      ERC=(0.,0.)
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE EKSCX( BX, S, Z, RHX, XK, IJ, INX1, INX2, EZS, ERS,
     &EZC, ERC, EZK, ERK)
C ***
C     COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
C     EXTENDED THIN WIRE APPROXIMATION.
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CON, GZ1, GZ2, GZP1, GZP2, GR1, GR2, GRP1, GRP2, EZS,
     & EZC, ERS, ERC, GRK1, GRK2, EZK, ERK, GZZ1, GZZ2
      COMMON  /TMI/ ZPK, RKB2, IJX
      DIMENSION  CONX(2)
      EQUIVALENCE(CONX,CON)
      DATA   CONX/0.,4.771341189D+0/
      IF( RHX.LT. BX) GOTO 1
      RH= RHX
      B= BX
      IRA=0
      GOTO 2
    1 RH= BX
      B= RHX
      IRA=1
    2 SH=.5* S
      IJX= IJ
      ZPK= XK* Z
      RHK= XK* RH
      RKB2= RHK* RHK
      SHK= XK* SH
      SS= SIN( SHK)
      CS= COS( SHK)
      Z2= SH- Z
      Z1=-( SH+ Z)
      A2= B* B
      IF( INX1.EQ.2) GOTO 3
      CALL GXX( Z1, RH, B, A2, XK, IRA, GZ1, GZP1, GR1, GRP1, GRK1,
     &GZZ1)
      GOTO 4
    3 CALL GX( Z1, RHX, XK, GZ1, GRK1)
      GZP1= GRK1* Z1
      GR1= GZ1/ RHX
      GRP1= GZP1/ RHX
      GRK1= GRK1* RHX
      GZZ1=(0.,0.)
    4 IF( INX2.EQ.2) GOTO 5
      CALL GXX( Z2, RH, B, A2, XK, IRA, GZ2, GZP2, GR2, GRP2, GRK2,
     &GZZ2)
      GOTO 6
    5 CALL GX( Z2, RHX, XK, GZ2, GRK2)
      GZP2= GRK2* Z2
      GR2= GZ2/ RHX
      GRP2= GZP2/ RHX
      GRK2= GRK2* RHX
      GZZ2=(0.,0.)
    6 EZS= CON*(( GZ2- GZ1)* CS* XK-( GZP2+ GZP1)* SS)
      EZC=- CON*(( GZ2+ GZ1)* SS* XK+( GZP2- GZP1)* CS)
      ERS=- CON*(( Z2* GRP2+ Z1* GRP1+ GR2+ GR1)* SS-( Z2* GR2- Z1* GR1
     &)* CS* XK)
      ERC=- CON*(( Z2* GRP2- Z1* GRP1+ GR2- GR1)* CS+( Z2* GR2+ Z1* GR1
     &)* SS* XK)
      ERK= CON*( GRK2- GRK1)
      CALL INTX(- SHK, SHK, RHK, IJ, CINT, SINT)
      BK= B* XK
      BK2= BK* BK*.25
      EZK=- CON*( GZP2- GZP1+ XK* XK*(1.- BK2)* CMPLX( CINT,- SINT)-
     &BK2*( GZZ2- GZZ1))
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
C      LOGICAL FUNCTION ENF( NUNIT)
C ***
C*********** THIS ROUTINE NOT USED ON VAX **************
C      IF (EOF,NUNIT) 1,2
C      IMPLICIT REAL (A-H,O-Z)
C    1 ENF=.TRUE.
C      RETURN
C    2 ENF=.FALSE.
C      RETURN
C      END
C ***
C     DOUBLE PRECISION 6/4/85
C
C     IMPLICIT REAL(A-H,O-Z)
C ***
      SUBROUTINE ERROR
      IMPLICIT INTEGER (A-Z)
      CHARACTER   MSG*80
C      CALL SYS$GETMSG(%VAL(RMSSTS),MSGLEN,MSG,,,)
C      CALL ERRSNS( FNUM, RMSSTS, RMSSTV, IUNIT, CNDVAL)
      CALL STR0PC( MSG, MSG)
      IND= INDEX( MSG,',')
      PRINT1 , MSG( IND+2: MSGLEN)
    1 FORMAT(//,'  ****  ERROR  ****   ',//,5X,A,//)
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE ETMNS( P1, P2, P3, P4, P5, P6, IPR, E)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
C ***
C
C     ETMNS FILLS THE ARRAY E WITH THE NEGATIVE OF THE ELECTRIC FIELD
C     INCIDENT ON THE STRUCTURE.  E IS THE RIGHT HAND SIDE OF THE MATRIX
C     EQUATION.
C
      IMPLICIT REAL (A-H,O-Z)
      COMPLEX  E, CX, CY, CZ, VSANT, TX1, TX2, ER, ET, EZH, ERH, VQD
     &, VQDS, ZRATI, ZRATI2, RRV, RRH, T1, TT1, TT2, FRATI
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ANGL/ SALP( NM)
      COMMON  /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
     &, IQDS(30), NVQD, NSANT, NQDS
      COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
     &KSYMP, IFAR, IPERF, T1, T2
      DIMENSION  CAB(1), SAB(1), E( N2M)
      DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
      EQUIVALENCE(CAB,ALP),(SAB,BET)
      EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
     &T2Z,ITAG)
      DATA   TP/6.283185308D+0/, RETA/2.654420938D-3/
      NEQ= N+2* M
      NQDS=0
C
C     APPLIED FIELD OF VOLTAGE SOURCES FOR TRANSMITTING CASE
C
      IF( IPR.GT.0.AND. IPR.NE.5) GOTO 5
      DO 1  I=1, NEQ
    1 E( I)=(0.,0.)
      IF( NSANT.EQ.0) GOTO 3
      DO 2  I=1, NSANT
      IS= ISANT( I)
    2 E( IS)=- VSANT( I)/( SI( IS)* WLAM)
    3 IF( NVQD.EQ.0) RETURN
      DO 4  I=1, NVQD
      IS= IVQD( I)
    4 CALL QDSRC( IS, VQD( I), E)
      RETURN
C
C     INCIDENT PLANE WAVE, LINEARLY POLARIZED.
C
    5 IF( IPR.GT.3) GOTO 19
      CTH= COS( P1)
      STH= SIN( P1)
      CPH= COS( P2)
      SPH= SIN( P2)
      CET= COS( P3)
      SET= SIN( P3)
      PX= CTH* CPH* CET- SPH* SET
      PY= CTH* SPH* CET+ CPH* SET
      PZ=- STH* CET
      WX=- STH* CPH
      WY=- STH* SPH
      WZ=- CTH
      QX= WY* PZ- WZ* PY
      QY= WZ* PX- WX* PZ
      QZ= WX* PY- WY* PX
      IF( KSYMP.EQ.1) GOTO 7
      IF( IPERF.EQ.1) GOTO 6
      RRV= SQRT(1.- ZRATI* ZRATI* STH* STH)
      RRH= ZRATI* CTH
      RRH=( RRH- RRV)/( RRH+ RRV)
      RRV= ZRATI* RRV
      RRV=-( CTH- RRV)/( CTH+ RRV)
      GOTO 7
    6 RRV=-(1.,0.)
      RRH=-(1.,0.)
    7 IF( IPR.GT.1) GOTO 13
      IF( N.EQ.0) GOTO 10
      DO 8  I=1, N
      ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I))
    8 E( I)=-( PX* CAB( I)+ PY* SAB( I)+ PZ* SALP( I))* CMPLX( COS( ARG
     &), SIN( ARG))
      IF( KSYMP.EQ.1) GOTO 10
      TT1=( PY* CPH- PX* SPH)*( RRH- RRV)
      CX= RRV* PX- TT1* SPH
      CY= RRV* PY+ TT1* CPH
      CZ=- RRV* PZ
      DO 9  I=1, N
      ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I))
    9 E( I)= E( I)-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I))* CMPLX(
     &COS( ARG), SIN( ARG))
   10 IF( M.EQ.0) RETURN
      I= LD+1
      I1= N-1
      DO 11  IS=1, M
      I= I-1
      I1= I1+2
      I2= I1+1
      ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I))
      TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA
      E( I2)=( QX* T1X( I)+ QY* T1Y( I)+ QZ* T1Z( I))* TT1
   11 E( I1)=( QX* T2X( I)+ QY* T2Y( I)+ QZ* T2Z( I))* TT1
      IF( KSYMP.EQ.1) RETURN
      TT1=( QY* CPH- QX* SPH)*( RRV- RRH)
      CX=-( RRH* QX- TT1* SPH)
      CY=-( RRH* QY+ TT1* CPH)
      CZ= RRH* QZ
      I= LD+1
      I1= N-1
      DO 12  IS=1, M
      I= I-1
      I1= I1+2
      I2= I1+1
      ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I))
      TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA
      E( I2)= E( I2)+( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT1
   12 E( I1)= E( I1)+( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT1
C
C     INCIDENT PLANE WAVE, ELLIPTIC POLARIZATION.
C
      RETURN
   13 TT1=-(0.,1.)* P6
      IF( IPR.EQ.3) TT1=- TT1
      IF( N.EQ.0) GOTO 16
      CX= PX+ TT1* QX
      CY= PY+ TT1* QY
      CZ= PZ+ TT1* QZ
      DO 14  I=1, N
      ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I))
   14 E( I)=-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I))* CMPLX( COS( ARG
     &), SIN( ARG))
      IF( KSYMP.EQ.1) GOTO 16
      TT2=( CY* CPH- CX* SPH)*( RRH- RRV)
      CX= RRV* CX- TT2* SPH
      CY= RRV* CY+ TT2* CPH
      CZ=- RRV* CZ
      DO 15  I=1, N
      ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I))
   15 E( I)= E( I)-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I))* CMPLX(
     &COS( ARG), SIN( ARG))
   16 IF( M.EQ.0) RETURN
      CX= QX- TT1* PX
      CY= QY- TT1* PY
      CZ= QZ- TT1* PZ
      I= LD+1
      I1= N-1
      DO 17  IS=1, M
      I= I-1
      I1= I1+2
      I2= I1+1
      ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I))
      TT2= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA
      E( I2)=( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT2
   17 E( I1)=( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT2
      IF( KSYMP.EQ.1) RETURN
      TT1=( CY* CPH- CX* SPH)*( RRV- RRH)
      CX=-( RRH* CX- TT1* SPH)
      CY=-( RRH* CY+ TT1* CPH)
      CZ= RRH* CZ
      I= LD+1
      I1= N-1
      DO 18  IS=1, M
      I= I-1
      I1= I1+2
      I2= I1+1
      ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I))
      TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA
      E( I2)= E( I2)+( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT1
   18 E( I1)= E( I1)+( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT1
C
C     INCIDENT FIELD OF AN ELEMENTARY CURRENT SOURCE.
C
      RETURN
   19 WZ= COS( P4)
      WX= WZ* COS( P5)
      WY= WZ* SIN( P5)
      WZ= SIN( P4)
      DS= P6*59.958
      DSH= P6/(2.* TP)
      NPM= N+ M
      IS= LD+1
      I1= N-1
      DO 24  I=1, NPM
      II= I
      IF( I.LE. N) GOTO 20
      IS= IS-1
      II= IS
      I1= I1+2
      I2= I1+1
   20 PX= X( II)- P1
      PY= Y( II)- P2
      PZ= Z( II)- P3
      RS= PX* PX+ PY* PY+ PZ* PZ
      IF( RS.LT.1.D-30) GOTO 24
      R= SQRT( RS)
      PX= PX/ R
      PY= PY/ R
      PZ= PZ/ R
      CTH= PX* WX+ PY* WY+ PZ* WZ
      STH= SQRT(1.- CTH* CTH)
      QX= PX- WX* CTH
      QY= PY- WY* CTH
      QZ= PZ- WZ* CTH
      ARG= SQRT( QX* QX+ QY* QY+ QZ* QZ)
      IF( ARG.LT.1.D-30) GOTO 21
      QX= QX/ ARG
      QY= QY/ ARG
      QZ= QZ/ ARG
      GOTO 22
   21 QX=1.
      QY=0.
      QZ=0.
   22 ARG=- TP* R
      TT1= CMPLX( COS( ARG), SIN( ARG))
      IF( I.GT. N) GOTO 23
      TT2= CMPLX(1.D+0,-1.D+0/( R* TP))/ RS
      ER= DS* TT1* TT2* CTH
      ET=.5* DS* TT1*((0.,1.)* TP/ R+ TT2)* STH
      EZH= ER* CTH- ET* STH
      ERH= ER* STH+ ET* CTH
      CX= EZH* WX+ ERH* QX
      CY= EZH* WY+ ERH* QY
      CZ= EZH* WZ+ ERH* QZ
      E( I)=-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I))
      GOTO 24
   23 PX= WY* QZ- WZ* QY
      PY= WZ* QX- WX* QZ
      PZ= WX* QY- WY* QX
      TT2= DSH* TT1* CMPLX(1./ R, TP)/ R* STH* SALP( II)
      CX= TT2* PX
      CY= TT2* PY
      CZ= TT2* PZ
      E( I2)= CX* T1X( II)+ CY* T1Y( II)+ CZ* T1Z( II)
      E( I1)= CX* T2X( II)+ CY* T2Y( II)+ CZ* T2Z( II)
   24 CONTINUE
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE FACGF( A, B, C, D, BX, IP, IX, NP, N1, MP, M1, N1C,
     &N2C)
C ***
C     FACGF COMPUTES AND FACTORS D-C(INV(A)B).
      IMPLICIT REAL (A-H,O-Z)
      COMPLEX  A, B, C, D, BX, SUM
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      DIMENSION  A(1), B( N1C,1), C( N1C,1), D( N2C,1), BX( N1C,1), IP(
     &1), IX(1)
      IF( N2C.EQ.0) RETURN
      IBFL=14
C     CONVERT B FROM BLOCKS OF ROWS ON T14 TO BLOCKS OF COL. ON T16
      IF( ICASX.LT.3) GOTO 1
      CALL REBLK( B, C, N1C, NPBX, N2C)
      IBFL=16
    1 NPB= NPBL
C     COMPUTE INV(A)B AND WRITE ON TAPE14
      IF( ICASX.EQ.2) REWIND 14
      DO 2  IB=1, NBBL
      IF( IB.EQ. NBBL) NPB= NLBL
      IF( ICASX.GT.1) READ( IBFL) (( BX( I, J), I=1, N1C), J=1, NPB)
      CALL SOLVES( A, IP, BX, N1C, NPB, NP, N1, MP, M1,13,13)
      IF( ICASX.EQ.2) REWIND 14
      IF( ICASX.GT.1) WRITE( 14) (( BX( I, J), I=1, N1C), J=1, NPB)
    2 CONTINUE
      IF( ICASX.EQ.1) GOTO 3
      REWIND 11
      REWIND 12
      REWIND 15
      REWIND IBFL
C     COMPUTE D-C(INV(A)B) AND WRITE ON TAPE11
    3 NPC= NPBL
      DO 8  IC=1, NBBL
      IF( IC.EQ. NBBL) NPC= NLBL
      IF( ICASX.EQ.1) GOTO 4
      READ( 15) (( C( I, J), I=1, N1C), J=1, NPC)
      READ( 12) (( D( I, J), I=1, N2C), J=1, NPC)
      REWIND 14
    4 NPB= NPBL
      NIC=0
      DO 7  IB=1, NBBL
      IF( IB.EQ. NBBL) NPB= NLBL
      IF( ICASX.GT.1) READ( 14) (( B( I, J), I=1, N1C), J=1, NPB)
      DO 6  I=1, NPB
      II= I+ NIC
      DO 6  J=1, NPC
      SUM=(0.,0.)
      DO 5  K=1, N1C
    5 SUM= SUM+ B( K, I)* C( K, J)
    6 D( II, J)= D( II, J)- SUM
    7 NIC= NIC+ NPBL
      IF( ICASX.GT.1) WRITE( 11) (( D( I, J), I=1, N2C), J=1, NPBL)
    8 CONTINUE
      IF( ICASX.EQ.1) GOTO 9
      REWIND 11
      REWIND 12
      REWIND 14
      REWIND 15
C     FACTOR D-C(INV(A)B)
    9 N1CP= N1C+1
      IF( ICASX.GT.1) GOTO 10
      CALL FACTR( N2C, D, IP( N1CP), N2C)
      GOTO 13
   10 IF( ICASX.EQ.4) GOTO 12
      NPB= NPBL
      IC=0
      DO 11  IB=1, NBBL
      IF( IB.EQ. NBBL) NPB= NLBL
      II= IC+1
      IC= IC+ N2C* NPB
   11 READ( 11) ( B( I,1), I= II, IC)
      REWIND 11
      CALL FACTR( N2C, B, IP( N1CP), N2C)
      NIC= N2C* N2C
      WRITE( 11) ( B( I,1), I=1, NIC)
      REWIND 11
      GOTO 13
   12 NBLSYS= NBLSYM
      NPSYS= NPSYM
      NLSYS= NLSYM
      ICASS= ICASE
      NBLSYM= NBBL
      NPSYM= NPBL
      NLSYM= NLBL
      ICASE=3
      CALL FACIO( B, N2C,1, IX( N1CP),11,12,16,11)
      CALL LUNSCR( B, N2C,1, IP( N1CP), IX( N1CP),12,11,16)
      NBLSYM= NBLSYS
      NPSYM= NPSYS
      NLSYM= NLSYS
      ICASE= ICASS
   13 RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE FACIO( A, NROW, NOP, IP, IU1, IU2, IU3, IU4)
C ***
C
C     FACIO CONTROLS I/O FOR OUT-OF-CORE FACTORIZATION
C
      IMPLICIT REAL (A-H,O-Z)
      COMPLEX  A
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      DIMENSION  A( NROW,1), IP( NROW)
      IT=2* NPSYM* NROW
      NBM= NBLSYM-1
      I1=1
      I2= IT
      I3= I2+1
      I4=2* IT
      TIME=0.
      REWIND IU1
      REWIND IU2
      DO 3  KK=1, NOP
      KA=( KK-1)* NROW+1
      IFILE3= IU1
      IFILE4= IU3
      DO 2  IXBLK1=1, NBM
      REWIND IU3
      REWIND IU4
      CALL BLCKIN( A, IFILE3, I1, I2,1,17)
      IXBP= IXBLK1+1
      DO 1  IXBLK2= IXBP, NBLSYM
      CALL BLCKIN( A, IFILE3, I3, I4,1,18)
      CALL SECNDS( T1)
      CALL LFACTR( A, NROW, IXBLK1, IXBLK2, IP( KA))
      CALL SECNDS( T2)
      TIME= TIME+ T2- T1
      IF( IXBLK2.EQ. IXBP) CALL BLCKOT( A, IU2, I1, I2,1,19)
      IF( IXBLK1.EQ. NBM.AND. IXBLK2.EQ. NBLSYM) IFILE4= IU2
      CALL BLCKOT( A, IFILE4, I3, I4,1,20)
    1 CONTINUE
      IFILE3= IU3
      IFILE4= IU4
      IF(( IXBLK1/2)*2.NE. IXBLK1) GOTO 2
      IFILE3= IU4
      IFILE4= IU3
    2 CONTINUE
    3 CONTINUE
      REWIND IU1
      REWIND IU2
      REWIND IU3
      REWIND IU4
      WRITE( 6,4)  TIME
C
      RETURN
    4 FORMAT(' CP TIME TAKEN FOR FACTORIZATION = ',1P,E12.5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE FACTR( N, A, IP, NDIM)
C ***
C
C     SUBROUTINE TO FACTOR A MATRIX INTO A UNIT LOWER TRIANGULAR MATRIX
C     AND AN UPPER TRIANGULAR MATRIX USING THE GAUSS-DOOLITTLE ALGORITHM
C     PRESENTED ON PAGES 411-416 OF A. RALSTON--A FIRST COURSE IN
C     NUMERICAL ANALYSIS.  COMMENTS BELOW REFER TO COMMENTS IN RALSTONS
C     TEXT.    (MATRIX TRANSPOSED.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  A, D, ARJ
      DIMENSION  A( NDIM, NDIM), IP( NDIM)
      COMMON  /SCRATM/ D( N2M)
      INTEGER  R, RM1, RP1, PJ, PR
      IFLG=0
C
C     STEP 1
C
      DO 9  R=1, N
      DO 1  K=1, N
      D( K)= A( R, K)
C
C     STEPS 2 AND 3
C
    1 CONTINUE
      RM1= R-1
      IF( RM1.LT.1) GOTO 4
      DO 3  J=1, RM1
      PJ= IP( J)
      ARJ= D( PJ)
      A( R, J)= ARJ
      D( PJ)= D( J)
      JP1= J+1
      DO 2  I= JP1, N
      D( I)= D( I)- A( J, I)* ARJ
    2 CONTINUE
    3 CONTINUE
C
C     STEP 4
C
    4 CONTINUE
      DMAX= REAL( D( R)* CONJG( D( R)))
      IP( R)= R
      RP1= R+1
      IF( RP1.GT. N) GOTO 6
      DO 5  I= RP1, N
      ELMAG= REAL( D( I)* CONJG( D( I)))
      IF( ELMAG.LT. DMAX) GOTO 5
      DMAX= ELMAG
      IP( R)= I
    5 CONTINUE
    6 CONTINUE
      IF( DMAX.LT.1.D-10) IFLG=1
      PR= IP( R)
      A( R, R)= D( PR)
C
C     STEP 5
C
      D( PR)= D( R)
      IF( RP1.GT. N) GOTO 8
      ARJ=1./ A( R, R)
      DO 7  I= RP1, N
      A( R, I)= D( I)* ARJ
    7 CONTINUE
    8 CONTINUE
      IF( IFLG.EQ.0) GOTO 9
      WRITE( 6,10)  R, DMAX
      IFLG=0
    9 CONTINUE
C
      RETURN
   10 FORMAT(1H ,'PIVOT(',I3,')=',1P,E16.8)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE FACTRS( NP, NROW, A, IP, IX, IU1, IU2, IU3, IU4)
C ***
C
C     FACTRS, FOR SYMMETRIC STRUCTURE, TRANSFORMS SUBMATRICIES TO FORM
C     MATRICIES OF THE SYMMETRIC MODES AND CALLS ROUTINE TO FACTOR
C     MATRICIES.  IF NO SYMMETRY, THE ROUTINE IS CALLED TO FACTOR THE
C     COMPLETE MATRIX.
C
      IMPLICIT REAL (A-H,O-Z)
      COMPLEX  A
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      DIMENSION  A(1), IP( NROW), IX( NROW)
      NOP= NROW/ NP
      IF( ICASE.GT.2) GOTO 2
      DO 1  KK=1, NOP
      KA=( KK-1)* NP+1
    1 CALL FACTR( NP, A( KA), IP( KA), NROW)
      RETURN
C
C     FACTOR SUBMATRICIES, OR FACTOR COMPLETE MATRIX IF NO SYMMETRY
C     EXISTS.
C
    2 IF( ICASE.GT.3) GOTO 3
      CALL FACIO( A, NROW, NOP, IX, IU1, IU2, IU3, IU4)
      CALL LUNSCR( A, NROW, NOP, IP, IX, IU2, IU3, IU4)
C
C     REWRITE THE MATRICES BY COLUMNS ON TAPE 13
C
      RETURN
    3 I2=2* NPBLK* NROW
      REWIND IU2
      DO 5  K=1, NOP
      REWIND IU1
      ICOLS= NPBLK
      IR2= K* NP
      IR1= IR2- NP+1
      DO 5  L=1, NBLOKS
      IF( NBLOKS.EQ.1.AND. K.GT.1) GOTO 4
      CALL BLCKIN( A, IU1,1, I2,1,602)
      IF( L.EQ. NBLOKS) ICOLS= NLAST
    4 IRR1= IR1
      IRR2= IR2
      DO 5  ICOLDX=1, ICOLS
      WRITE( IU2) ( A( I), I= IRR1, IRR2)
      IRR1= IRR1+ NROW
      IRR2= IRR2+ NROW
    5 CONTINUE
      REWIND IU1
      REWIND IU2
      IF( ICASE.EQ.5) GOTO 8
      REWIND IU3
      IRR1= NP* NP
      DO 7  KK=1, NOP
      IR1=1- NP
      IR2=0
      DO 6  I=1, NP
      IR1= IR1+ NP
      IR2= IR2+ NP
    6 READ( IU2) ( A( J), J= IR1, IR2)
      KA=( KK-1)* NP+1
      CALL FACTR( NP, A, IP( KA), NP)
      WRITE( IU3) ( A( I), I=1, IRR1)
    7 CONTINUE
      REWIND IU2
      REWIND IU3
      RETURN
    8 I2=2* NPSYM* NP
      DO 10  KK=1, NOP
      J2= NPSYM
      DO 10  L=1, NBLSYM
      IF( L.EQ. NBLSYM) J2= NLSYM
      IR1=1- NP
      IR2=0
      DO 9  J=1, J2
      IR1= IR1+ NP
      IR2= IR2+ NP
    9 READ( IU2) ( A( I), I= IR1, IR2)
   10 CALL BLCKOT( A, IU1,1, I2,1,193)
      REWIND IU1
      CALL FACIO( A, NP, NOP, IX, IU1, IU2, IU3, IU4)
      CALL LUNSCR( A, NP, NOP, IP, IX, IU2, IU3, IU4)
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
C      COMPLEX FUNCTION FBAR( P)
      FUNCTION FBAR( P)
C ***
C
C     FBAR IS SOMMERFELD ATTENUATION FUNCTION FOR NUMERICAL DISTANCE P
C
C      IMPLICIT REAL (A-H,O-Z)
      COMPLEX  Z, ZS, SUM, POW, TERM, P, FJ, FBAR
      DIMENSION  FJX(2)
      EQUIVALENCE(FJ,FJX)
      DATA   TOSP/1.128379167D+0/, ACCS/1.D-12/, SP/1.772453851D+0/,
     &FJX/0.,1./
      Z= FJ* SQRT( P)
C
C     SERIES EXPANSION
C
      IF( ABS( Z).GT.3.) GOTO 3
      ZS= Z* Z
      SUM= Z
      POW= Z
      DO 1  I=1,100
      POW=- POW* ZS/ DFLOAT( I)
      TERM= POW/(2.* I+1.)
      SUM= SUM+ TERM
      TMS= REAL( TERM* CONJG( TERM))
      SMS= REAL( SUM* CONJG( SUM))
      IF( TMS/ SMS.LT. ACCS) GOTO 2
    1 CONTINUE
    2 FBAR=1.-(1.- SUM* TOSP)* Z* EXP( ZS)* SP
C
C     ASYMPTOTIC EXPANSION
C
      RETURN
    3 IF( REAL( Z).GE.0.) GOTO 4
      MINUS=1
      Z=- Z
      GOTO 5
    4 MINUS=0
    5 ZS=.5/( Z* Z)
      SUM=(0.,0.)
      TERM=(1.,0.)
      DO 6  I=1,6
      TERM=- TERM*(2.* I-1.)* ZS
    6 SUM= SUM+ TERM
      IF( MINUS.EQ.1) SUM= SUM-2.* SP* Z* EXP( Z* Z)
      FBAR=- SUM
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE FBLOCK( NROW, NCOL, IMAX, IRNGF, IPSYM)
C ***
C     FBLOCK SETS PARAMETERS FOR OUT-OF-CORE SOLUTION FOR THE PRIMARY
C     MATRIX (A)
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  SSX, DETER
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      COMMON  /SMAT/ SSX(16,16)
      IMX1= IMAX- IRNGF
      IF( NROW* NCOL.GT. IMX1) GOTO 2
      NBLOKS=1
      NPBLK= NROW
      NLAST= NROW
      IMAT= NROW* NCOL
      IF( NROW.NE. NCOL) GOTO 1
      ICASE=1
      RETURN
    1 ICASE=2
      GOTO 5
    2 IF( NROW.NE. NCOL) GOTO 3
      ICASE=3
      NPBLK= IMAX/(2* NCOL)
      NPSYM= IMX1/ NCOL
      IF( NPSYM.LT. NPBLK) NPBLK= NPSYM
      IF( NPBLK.LT.1) GOTO 12
      NBLOKS=( NROW-1)/ NPBLK
      NLAST= NROW- NBLOKS* NPBLK
      NBLOKS= NBLOKS+1
      NBLSYM= NBLOKS
      NPSYM= NPBLK
      NLSYM= NLAST
      IMAT= NPBLK* NCOL
      WRITE( 6,14)  NBLOKS, NPBLK, NLAST
      GOTO 11
    3 NPBLK= IMAX/ NCOL
      IF( NPBLK.LT.1) GOTO 12
      IF( NPBLK.GT. NROW) NPBLK= NROW
      NBLOKS=( NROW-1)/ NPBLK
      NLAST= NROW- NBLOKS* NPBLK
      NBLOKS= NBLOKS+1
      WRITE( 6,14)  NBLOKS, NPBLK, NLAST
      IF( NROW* NROW.GT. IMX1) GOTO 4
      ICASE=4
      NBLSYM=1
      NPSYM= NROW
      NLSYM= NROW
      IMAT= NROW* NROW
      WRITE( 6,15)
      GOTO 5
    4 ICASE=5
      NPSYM= IMAX/(2* NROW)
      NBLSYM= IMX1/ NROW
      IF( NBLSYM.LT. NPSYM) NPSYM= NBLSYM
      IF( NPSYM.LT.1) GOTO 12
      NBLSYM=( NROW-1)/ NPSYM
      NLSYM= NROW- NBLSYM* NPSYM
      NBLSYM= NBLSYM+1
      WRITE( 6,16)  NBLSYM, NPSYM, NLSYM
      IMAT= NPSYM* NROW
    5 NOP= NCOL/ NROW
      IF( NOP* NROW.NE. NCOL) GOTO 13
C
C     SET UP SSX MATRIX FOR ROTATIONAL SYMMETRY.
C
      IF( IPSYM.GT.0) GOTO 7
      PHAZ=6.2831853072D+0/ NOP
      DO 6  I=2, NOP
      DO 6  J= I, NOP
      ARG= PHAZ* DFLOAT( I-1)* DFLOAT( J-1)
      SSX( I, J)= CMPLX( COS( ARG), SIN( ARG))
    6 SSX( J, I)= SSX( I, J)
C
C     SET UP SSX MATRIX FOR PLANE SYMMETRY
C
      GOTO 11
    7 KK=1
      SSX(1,1)=(1.,0.)
      IF(( NOP.EQ.2).OR.( NOP.EQ.4).OR.( NOP.EQ.8)) GOTO 8
      STOP
    8 KA= NOP/2
      IF( NOP.EQ.8) KA=3
      DO 10  K=1, KA
      DO 9  I=1, KK
      DO 9  J=1, KK
      DETER= SSX( I, J)
      SSX( I, J+ KK)= DETER
      SSX( I+ KK, J+ KK)=- DETER
    9 SSX( I+ KK, J)= DETER
   10 KK= KK*2
   11 RETURN
   12 WRITE( 6,17)  NROW, NCOL
      STOP
   13 WRITE( 6,18)  NROW, NCOL
C
      STOP
   14 FORMAT(//' MATRIX FILE STORAGE -  NO. BLOCKS=',I5,' COLUMNS PE',
     &'R BLOCK=',I5,' COLUMNS IN LAST BLOCK=',I5)
   15 FORMAT(' SUBMATRICIES FIT IN CORE')
   16 FORMAT(' SUBMATRIX PARTITIONING -  NO. BLOCKS=',I5,' COLUMNS P',
     &'ER BLOCK=',I5,' COLUMNS IN LAST BLOCK=',I5)
   17 FORMAT(' ERROR - INSUFFICIENT STORAGE FOR MATRIX',2I5)
   18 FORMAT(' SYMMETRY ERROR - NROW,NCOL=',2I5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE FBNGF( NEQ, NEQ2, IRESRV, IB11, IC11, ID11, IX11)
C ***
C     FBNGF SETS THE BLOCKING PARAMETERS FOR THE B, C, AND D ARRAYS FOR
C     OUT-OF-CORE STORAGE.
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      IRESX= IRESRV- IMAT
      NBLN= NEQ* NEQ2
      NDLN= NEQ2* NEQ2
      NBCD=2* NBLN+ NDLN
      IF( NBCD.GT. IRESX) GOTO 1
      ICASX=1
      IB11= IMAT+1
      GOTO 2
    1 IF( ICASE.LT.3) GOTO 3
      IF( NBCD.GT. IRESRV.OR. NBLN.GT. IRESX) GOTO 3
      ICASX=2
      IB11=1
    2 NBBX=1
      NPBX= NEQ
      NLBX= NEQ
      NBBL=1
      NPBL= NEQ2
      NLBL= NEQ2
      GOTO 5
    3 IR= IRESRV
      IF( ICASE.LT.3) IR= IRESX
      ICASX=3
      IF( NDLN.GT. IR) ICASX=4
      NBCD=2* NEQ+ NEQ2
      NPBL= IR/ NBCD
      NLBL= IR/(2* NEQ2)
      IF( NLBL.LT. NPBL) NPBL= NLBL
      IF( ICASE.LT.3) GOTO 4
      NLBL= IRESX/ NEQ
      IF( NLBL.LT. NPBL) NPBL= NLBL
    4 IF( NPBL.LT.1) GOTO 6
      NBBL=( NEQ2-1)/ NPBL
      NLBL= NEQ2- NBBL* NPBL
      NBBL= NBBL+1
      NBLN= NEQ* NPBL
      IR= IR- NBLN
      NPBX= IR/ NEQ2
      IF( NPBX.GT. NEQ) NPBX= NEQ
      NBBX=( NEQ-1)/ NPBX
      NLBX= NEQ- NBBX* NPBX
      NBBX= NBBX+1
      IB11=1
      IF( ICASE.LT.3) IB11= IMAT+1
    5 IC11= IB11+ NBLN
      ID11= IC11+ NBLN
      IX11= IMAT+1
      WRITE( 6,11)  NEQ2
      IF( ICASX.EQ.1) RETURN
      WRITE( 6,8)  ICASX
      WRITE( 6,9)  NBBX, NPBX, NLBX
      WRITE( 6,10)  NBBL, NPBL, NLBL
      RETURN
    6 WRITE( 6,7)  IRESRV, IMAT, NEQ, NEQ2
C
      STOP
    7 FORMAT(55H ERROR - INSUFFICIENT STORAGE FOR INTERACTION MATRICIES
     &,'  IRESRV,IMAT,NEQ,NEQ2 =',4I5)
    8 FORMAT(48H FILE STORAGE FOR NEW MATRIX SECTIONS -  ICASX =,I2)
    9 FORMAT(' B FILLED BY ROWS -',15X,'NO. BLOCKS =',I3,3X,'ROWS P',
     &'ER BLOCK =',I3,3X,'ROWS IN LAST BLOCK =',I3)
   10 FORMAT(32H B BY COLUMNS, C AND D BY ROWS -,2X,12HNO. BLOCKS =,I3,
     &4X,15HR/C PER BLOCK =,I3,4X,19HR/C IN LAST BLOCK =,I3)
   11 FORMAT(//,35H N.G.F. - NUMBER OF NEW UNKNOWNS IS,I4)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE FFLD( THET, PHI, ETH, EPH)
C ***
C
C     FFLD CALCULATES THE FAR ZONE RADIATED ELECTRIC FIELDS,
C     THE FACTOR EXP(J*K*R)/(R/LAMDA) NOT INCLUDED
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CIX, CIY, CIZ, EXA, ETH, EPH, CONST, CCX, CCY, CCZ,
     &CDP, CUR
      COMPLEX  ZRATI, ZRSIN, RRV, RRH, RRV1, RRH1, RRV2, RRH2,
     &ZRATI2, TIX, TIY, TIZ, T1, ZSCRN, EX, EY, EZ, GX, GY, GZ, FRATI
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ANGL/ SALP( NM)
      COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
     &CII( NM), CUR( N3M)
      COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
     &KSYMP, IFAR, IPERF, T1, T2
      DIMENSION  CAB(1), SAB(1), CONSX(2)
      EQUIVALENCE(CAB,ALP),(SAB,BET),(CONST,CONSX)
      DATA   PI, TP, ETA/3.141592654D+0,6.283185308D+0,376.73/
      DATA   CONSX/0.,-29.97922085D+0/
      PHX=- SIN( PHI)
      PHY= COS( PHI)
      ROZ= COS( THET)
      ROZS= ROZ
      THX= ROZ* PHY
      THY=- ROZ* PHX
      THZ=- SIN( THET)
      ROX=- THZ* PHY
      ROY= THZ* PHX
C
C     LOOP FOR STRUCTURE IMAGE IF ANY
C
      IF( N.EQ.0) GOTO 20
C
C     CALCULATION OF REFLECTION COEFFECIENTS
C
      DO 19  K=1, KSYMP
      IF( K.EQ.1) GOTO 4
C
C     FOR PERFECT GROUND
C
      IF( IPERF.NE.1) GOTO 1
      RRV=-(1.,0.)
      RRH=-(1.,0.)
C
C     FOR INFINITE PLANAR GROUND
C
      GOTO 2
    1 ZRSIN= SQRT(1.- ZRATI* ZRATI* THZ* THZ)
      RRV=-( ROZ- ZRATI* ZRSIN)/( ROZ+ ZRATI* ZRSIN)
      RRH=( ZRATI* ROZ- ZRSIN)/( ZRATI* ROZ+ ZRSIN)
C
C     FOR THE CLIFF PROBLEM, TWO REFLCTION COEFFICIENTS CALCULATED
C
    2 IF( IFAR.LE.1) GOTO 3
      RRV1= RRV
      RRH1= RRH
      TTHET= TAN( THET)
      IF( IFAR.EQ.4) GOTO 3
      ZRSIN= SQRT(1.- ZRATI2* ZRATI2* THZ* THZ)
      RRV2=-( ROZ- ZRATI2* ZRSIN)/( ROZ+ ZRATI2* ZRSIN)
      RRH2=( ZRATI2* ROZ- ZRSIN)/( ZRATI2* ROZ+ ZRSIN)
      DARG=- TP*2.* CH* ROZ
    3 ROZ=- ROZ
      CCX= CIX
      CCY= CIY
      CCZ= CIZ
    4 CIX=(0.,0.)
      CIY=(0.,0.)
C
C     LOOP OVER STRUCTURE SEGMENTS
C
      CIZ=(0.,0.)
      DO 17  I=1, N
      OMEGA=-( ROX* CAB( I)+ ROY* SAB( I)+ ROZ* SALP( I))
      EL= PI* SI( I)
      SILL= OMEGA* EL
      TOP= EL+ SILL
      BOT= EL- SILL
      IF( ABS( OMEGA).LT.1.D-7) GOTO 5
      A=2.* SIN( SILL)/ OMEGA
      GOTO 6
    5 A=(2.- OMEGA* OMEGA* EL* EL/3.)* EL
    6 IF( ABS( TOP).LT.1.D-7) GOTO 7
      TOO= SIN( TOP)/ TOP
      GOTO 8
    7 TOO=1.- TOP* TOP/6.
    8 IF( ABS( BOT).LT.1.D-7) GOTO 9
      BOO= SIN( BOT)/ BOT
      GOTO 10
    9 BOO=1.- BOT* BOT/6.
   10 B= EL*( BOO- TOO)
      C= EL*( BOO+ TOO)
      RR= A* AIR( I)+ B* BII( I)+ C* CIR( I)
      RI= A* AII( I)- B* BIR( I)+ C* CII( I)
      ARG= TP*( X( I)* ROX+ Y( I)* ROY+ Z( I)* ROZ)
      IF( K.EQ.2.AND. IFAR.GE.2) GOTO 11
C
C     SUMMATION FOR FAR FIELD INTEGRAL
C
      EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI)
      CIX= CIX+ EXA* CAB( I)
      CIY= CIY+ EXA* SAB( I)
      CIZ= CIZ+ EXA* SALP( I)
C
C     CALCULATION OF IMAGE CONTRIBUTION IN CLIFF AND GROUND SCREEN
C     PROBLEMS.
C
      GOTO 17
C
C     SPECULAR POINT DISTANCE
C
   11 DR= Z( I)* TTHET
      D= DR* PHY+ X( I)
      IF( IFAR.EQ.2) GOTO 13
      D= SQRT( D* D+( Y( I)- DR* PHX)**2)
      IF( IFAR.EQ.3) GOTO 13
C
C     RADIAL WIRE GROUND SCREEN REFLECTION COEFFICIENT
C
      IF(( SCRWL- D).LT.0.) GOTO 12
      D= D+ T2
      ZSCRN= T1* D* LOG( D/ T2)
      ZSCRN=( ZSCRN* ZRATI)/( ETA* ZRATI+ ZSCRN)
      ZRSIN= SQRT(1.- ZSCRN* ZSCRN* THZ* THZ)
      RRV=( ROZ+ ZSCRN* ZRSIN)/(- ROZ+ ZSCRN* ZRSIN)
      RRH=( ZSCRN* ROZ+ ZRSIN)/( ZSCRN* ROZ- ZRSIN)
      GOTO 16
   12 IF( IFAR.EQ.4) GOTO 14
      IF( IFAR.EQ.5) D= DR* PHY+ X( I)
   13 IF(( CL- D).LE.0.) GOTO 15
   14 RRV= RRV1
      RRH= RRH1
      GOTO 16
   15 RRV= RRV2
      RRH= RRH2
      ARG= ARG+ DARG
C
C     CONTRIBUTION OF EACH IMAGE SEGMENT MODIFIED BY REFLECTION COEF. ,
C     FOR CLIFF AND GROUND SCREEN PROBLEMS
C
   16 EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI)
      TIX= EXA* CAB( I)
      TIY= EXA* SAB( I)
      TIZ= EXA* SALP( I)
      CDP=( TIX* PHX+ TIY* PHY)*( RRH- RRV)
      CIX= CIX+ TIX* RRV+ CDP* PHX
      CIY= CIY+ TIY* RRV+ CDP* PHY
      CIZ= CIZ- TIZ* RRV
   17 CONTINUE
      IF( K.EQ.1) GOTO 19
C
C     CALCULATION OF CONTRIBUTION OF STRUCTURE IMAGE FOR INFINITE GROUND
C
      IF( IFAR.GE.2) GOTO 18
      CDP=( CIX* PHX+ CIY* PHY)*( RRH- RRV)
      CIX= CCX+ CIX* RRV+ CDP* PHX
      CIY= CCY+ CIY* RRV+ CDP* PHY
      CIZ= CCZ- CIZ* RRV
      GOTO 19
   18 CIX= CIX+ CCX
      CIY= CIY+ CCY
      CIZ= CIZ+ CCZ
   19 CONTINUE
      IF( M.GT.0) GOTO 21
      ETH=( CIX* THX+ CIY* THY+ CIZ* THZ)* CONST
      EPH=( CIX* PHX+ CIY* PHY)* CONST
      RETURN
   20 CIX=(0.,0.)
      CIY=(0.,0.)
      CIZ=(0.,0.)
C
C     ELECTRIC FIELD COMPONENTS
C
   21 ROZ= ROZS
      RFL=-1.
      DO 25  IP=1, KSYMP
      RFL=- RFL
      RRZ= ROZ* RFL
      CALL FFLDS( ROX, ROY, RRZ, CUR( N+1), GX, GY, GZ)
      IF( IP.EQ.2) GOTO 22
      EX= GX
      EY= GY
      EZ= GZ
      GOTO 25
   22 IF( IPERF.NE.1) GOTO 23
      GX=- GX
      GY=- GY
      GZ=- GZ
      GOTO 24
   23 RRV= SQRT(1.- ZRATI* ZRATI* THZ* THZ)
      RRH= ZRATI* ROZ
      RRH=( RRH- RRV)/( RRH+ RRV)
      RRV= ZRATI* RRV
      RRV=-( ROZ- RRV)/( ROZ+ RRV)
      ETH=( GX* PHX+ GY* PHY)*( RRH- RRV)
      GX= GX* RRV+ ETH* PHX
      GY= GY* RRV+ ETH* PHY
      GZ= GZ* RRV
   24 EX= EX+ GX
      EY= EY+ GY
      EZ= EZ- GZ
   25 CONTINUE
      EX= EX+ CIX* CONST
      EY= EY+ CIY* CONST
      EZ= EZ+ CIZ* CONST
      ETH= EX* THX+ EY* THY+ EZ* THZ
      EPH= EX* PHX+ EY* PHY
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE FFLDS( ROX, ROY, ROZ, SCUR, EX, EY, EZ)
C ***
C     CALCULATES THE XYZ COMPONENTS OF THE ELECTRIC FIELD DUE TO
C     SURFACE CURRENTS
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CT, CONS, SCUR, EX, EY, EZ
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      DIMENSION  XS(1), YS(1), ZS(1), S(1), SCUR(1), CONSX(2)
      EQUIVALENCE(XS,X),(YS,Y),(ZS,Z),(S,BI),(CONS,CONSX)
      DATA   TPI/6.283185308D+0/, CONSX/0.,188.365/
      EX=(0.,0.)
      EY=(0.,0.)
      EZ=(0.,0.)
      I= LD+1
      DO 1  J=1, M
      I= I-1
      ARG= TPI*( ROX* XS( I)+ ROY* YS( I)+ ROZ* ZS( I))
      CT= CMPLX( COS( ARG)* S( I), SIN( ARG)* S( I))
      K=3* J
      EX= EX+ SCUR( K-2)* CT
      EY= EY+ SCUR( K-1)* CT
      EZ= EZ+ SCUR( K)* CT
    1 CONTINUE
      CT= ROX* EX+ ROY* EY+ ROZ* EZ
      EX= CONS*( CT* ROX- EX)
      EY= CONS*( CT* ROY- EY)
      EZ= CONS*( CT* ROZ- EZ)
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE GF( ZK, CO, SI)
C ***
C
C     GF COMPUTES THE INTEGRAND EXP(JKR)/(KR) FOR NUMERICAL INTEGRATION.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /TMI/ ZPK, RKB2, IJ
      ZDK= ZK- ZPK
      RK= SQRT( RKB2+ ZDK* ZDK)
      SI= SIN( RK)/ RK
      IF( IJ) 1,2,1
    1 CO= COS( RK)/ RK
      RETURN
    2 IF( RK.LT..2) GOTO 3
      CO=( COS( RK)-1.)/ RK
      RETURN
    3 RKS= RK* RK
      CO=((-1.38888889D-3* RKS+4.16666667D-2)* RKS-.5)* RK
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE GFIL( IPRT)
C ***
C
C     GFIL READS THE N.G.F. FILE
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CM, SSX, ZRATI, ZRATI2, T1, ZARRAY, AR1, AR2, AR3,
     &EPSCF, FRATI
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /CMB/ CM(90000)
      COMMON  /ANGL/ SALP( NM)
      COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
     &KSYMP, IFAR, IPERF, T1, T2
      COMMON  /GGRID/ AR1(11,10,4), AR2(17,5,4), AR3(9,8,4), EPSCF, DXA
     &(3), DYA(3), XSA(3), YSA(3), NXA(3), NYA(3)
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      COMMON  /SMAT/ SSX(16,16)
      COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
      COMMON  /SAVE/ IP( N2M), KCOM, COM(19,5), EPSR, SIG, SCRWLT,
     &SCRWRT, FMHZ
      DATA   IGFL/20/
      REWIND IGFL
      READ( IGFL)  N1, NP, M1, MP, WLAM, FMHZ, IPSYM, KSYMP, IPERF,
     &NRADL, EPSR, SIG, SCRWLT, SCRWRT, NLODF, KCOM
      N= N1
      M= M1
      N2= N1+1
      M2= M1+1
C     READ SEG. DATA AND CONVERT BACK TO END COORD. IN UNITS OF METERS
      IF( N1.EQ.0) GOTO 2
      READ( IGFL) ( X( I), I=1, N1),( Y( I), I=1, N1),( Z( I), I=1, N1)
     &
      READ( IGFL) ( SI( I), I=1, N1),( BI( I), I=1, N1),( ALP( I), I=1,
     & N1)
      READ( IGFL) ( BET( I), I=1, N1),( SALP( I), I=1, N1)
      READ( IGFL) ( ICON1( I), I=1, N1),( ICON2( I), I=1, N1)
      READ( IGFL) ( ITAG( I), I=1, N1)
      IF( NLODF.NE.0) READ( IGFL) ( ZARRAY( I), I=1, N1)
      DO 1  I=1, N1
      XI= X( I)* WLAM
      YI= Y( I)* WLAM
      ZI= Z( I)* WLAM
      DX= SI( I)*.5* WLAM
      X( I)= XI- ALP( I)* DX
      Y( I)= YI- BET( I)* DX
      Z( I)= ZI- SALP( I)* DX
      SI( I)= XI+ ALP( I)* DX
      ALP( I)= YI+ BET( I)* DX
      BET( I)= ZI+ SALP( I)* DX
      BI( I)= BI( I)* WLAM
    1 CONTINUE
    2 IF( M1.EQ.0) GOTO 4
C     READ PATCH DATA AND CONVERT TO METERS
      J= LD- M1+1
      READ( IGFL) ( X( I), I= J, LD),( Y( I), I= J, LD),( Z( I), I= J,
     &LD)
      READ( IGFL) ( SI( I), I= J, LD),( BI( I), I= J, LD),( ALP( I), I=
     & J, LD)
      READ( IGFL) ( BET( I), I= J, LD),( SALP( I), I= J, LD)
      READ( IGFL) ( ICON1( I), I= J, LD),( ICON2( I), I= J, LD)
      READ( IGFL) ( ITAG( I), I= J, LD)
      DX= WLAM* WLAM
      DO 3  I= J, LD
      X( I)= X( I)* WLAM
      Y( I)= Y( I)* WLAM
      Z( I)= Z( I)* WLAM
    3 BI( I)= BI( I)* DX
    4 READ( IGFL)  ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, NLSYM,
     &IMAT
      IF( IPERF.EQ.2) READ( IGFL)  AR1, AR2, AR3, EPSCF, DXA, DYA, XSA,
     & YSA, NXA, NYA
      NEQ= N1+2* M1
      NPEQ= NP+2* MP
      NOP= NEQ/ NPEQ
      IF( NOP.GT.1) READ( IGFL) (( SSX( I, J), I=1, NOP), J=1, NOP)
C     READ MATRIX A AND WRITE TAPE13 FOR OUT OF CORE
      READ( IGFL) ( IP( I), I=1, NEQ), COM
      IF( ICASE.GT.2) GOTO 5
      IOUT= NEQ* NPEQ
      READ( IGFL) ( CM( I), I=1, IOUT)
      GOTO 10
    5 REWIND 13
      IF( ICASE.NE.4) GOTO 7
      IOUT= NPEQ* NPEQ
      DO 6  K=1, NOP
      READ( IGFL) ( CM( J), J=1, IOUT)
    6 WRITE( 13) ( CM( J), J=1, IOUT)
      GOTO 9
    7 IOUT= NPSYM* NPEQ*2
      NBL2=2* NBLSYM
      DO 8  IOP=1, NOP
      DO 8  I=1, NBL2
      CALL BLCKIN( CM, IGFL,1, IOUT,1,206)
    8 CALL BLCKOT( CM,13,1, IOUT,1,205)
    9 REWIND 13
C     WRITE(6,N) G.F. HEADING
   10 REWIND IGFL
      WRITE( 6,16)
      WRITE( 6,14)
      WRITE( 6,14)
      WRITE( 6,17)
      WRITE( 6,18)  N1, M1
      IF( NOP.GT.1) WRITE( 6,19)  NOP
      WRITE( 6,20)  IMAT, ICASE
      IF( ICASE.LT.3) GOTO 11
      NBL2= NEQ* NPEQ
      WRITE( 6,21)  NBL2
   11 WRITE( 6,22)  FMHZ
      IF( KSYMP.EQ.2.AND. IPERF.EQ.1) WRITE( 6,23)
      IF( KSYMP.EQ.2.AND. IPERF.EQ.0) WRITE( 6,27)
      IF( KSYMP.EQ.2.AND. IPERF.EQ.2) WRITE( 6,28)
      IF( KSYMP.EQ.2.AND. IPERF.NE.1) WRITE( 6,24)  EPSR, SIG
      WRITE( 6,17)
      DO 12  J=1, KCOM
   12 WRITE( 6,15) ( COM( I, J), I=1,19)
      WRITE( 6,17)
      WRITE( 6,14)
      WRITE( 6,14)
      WRITE( 6,16)
      IF( IPRT.EQ.0) RETURN
      WRITE( 6,25)
      DO 13  I=1, N1
   13 WRITE( 6,26)  I, X( I), Y( I), Z( I), SI( I), ALP( I), BET( I)
C
      RETURN
   14 FORMAT(5X,'**************************************************',
     &'**********************************')
   15 FORMAT(5X,3H** ,19A4,3H **)
   16 FORMAT(////)
   17 FORMAT(5X,2H**,80X,2H**)
   18 FORMAT(5X,'** NUMERICAL GREEN S FUNCTION',53X,2H**,/,5X,'** NO',
     &'. SEGMENTS =',I4,10X,'NO. PATCHES =',I4,34X,2H**)
   19 FORMAT(5X,'** NO. SYMMETRIC SECTIONS =',I4,51X,2H**)
   20 FORMAT(5X,'** N.G.F. MATRIX -  CORE STORAGE =',I7,' COMPLEX NU',
     &'MBERS,  CASE',I2,16X,2H**)
   21 FORMAT(5X,2H**,19X,'MATRIX SIZE =',I7,' COMPLEX NUMBERS',25X,'**')
   22 FORMAT(5X,'** FREQUENCY =',1P,E12.5,' MHZ.',51X,2H**)
   23 FORMAT(5X,'** PERFECT GROUND',65X,2H**)
   24 FORMAT(5X,'** GROUND PARAMETERS - DIELECTRIC CONSTANT =',1P,E12.5,
     &26X,'**',/,5X,'**',21X,'CONDUCTIVITY =',E12.5,' MHOS/M.',25X,'**')
   25 FORMAT(39X,'NUMERICAL GREEN S FUNCTION DATA',/,41X,'COORDINATES',
     &' OF SEGMENT ENDS',/,51X,'(METERS)',/,5X,'SEG.',11X,
     &'- - - END ON''E - - -',26X,'- - - END TWO - - -',/,6X,3HNO.,6X,1
     &HX,14X,1HY,14X,1HZ,14X,1HX,14X,1HY,14X,1HZ)
   26 FORMAT(1X,I7,1P,6E15.6)
   27 FORMAT(5X,'** FINITE GROUND.  REFLECTION COEFFICIENT APPROXIMAT',
     &'ION',27X,2H**)
   28 FORMAT(5X,'** FINITE GROUND.  SOMMERFELD SOLUTION',44X,'**')
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE GFLD( RHO, PHI, RZ, ETH, EPI, ERD, UX, KSYMP)
C ***
C
C     GFLD COMPUTES THE RADIATED FIELD INCLUDING GROUND WAVE.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CUR, EPI, CIX, CIY, CIZ, EXA, XX1, XX2, U, U2, ERV,
     &EZV, ERH, EPH
      COMPLEX  EZH, EX, EY, ETH, UX, ERD
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ANGL/ SALP( NM)
      COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
     &CII( NM), CUR( N3M)
      COMMON  /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH
      DIMENSION  CAB(1), SAB(1)
      EQUIVALENCE(CAB(1),ALP(1)),(SAB(1),BET(1))
      DATA   PI, TP/3.141592654D+0,6.283185308D+0/
      R= SQRT( RHO* RHO+ RZ* RZ)
      IF( KSYMP.EQ.1) GOTO 1
      IF( ABS( UX).GT..5) GOTO 1
      IF( R.GT.1.E5) GOTO 1
C
C     COMPUTATION OF SPACE WAVE ONLY
C
      GOTO 4
    1 IF( RZ.LT.1.D-20) GOTO 2
      THET= ATAN( RHO/ RZ)
      GOTO 3
    2 THET= PI*.5
    3 CALL FFLD( THET, PHI, ETH, EPI)
      ARG=- TP* R
      EXA= CMPLX( COS( ARG), SIN( ARG))/ R
      ETH= ETH* EXA
      EPI= EPI* EXA
      ERD=(0.,0.)
C
C     COMPUTATION OF SPACE AND GROUND WAVES.
C
      RETURN
    4 U= UX
      U2= U* U
      PHX=- SIN( PHI)
      PHY= COS( PHI)
      RX= RHO* PHY
      RY=- RHO* PHX
      CIX=(0.,0.)
      CIY=(0.,0.)
C
C     SUMMATION OF FIELD FROM INDIVIDUAL SEGMENTS
C
      CIZ=(0.,0.)
      DO 17  I=1, N
      DX= CAB( I)
      DY= SAB( I)
      DZ= SALP( I)
      RIX= RX- X( I)
      RIY= RY- Y( I)
      RHS= RIX* RIX+ RIY* RIY
      RHP= SQRT( RHS)
      IF( RHP.LT.1.D-6) GOTO 5
      RHX= RIX/ RHP
      RHY= RIY/ RHP
      GOTO 6
    5 RHX=1.
      RHY=0.
    6 CALP=1.- DZ* DZ
      IF( CALP.LT.1.D-6) GOTO 7
      CALP= SQRT( CALP)
      CBET= DX/ CALP
      SBET= DY/ CALP
      CPH= RHX* CBET+ RHY* SBET
      SPH= RHY* CBET- RHX* SBET
      GOTO 8
    7 CPH= RHX
      SPH= RHY
    8 EL= PI* SI( I)
C
C     INTEGRATION OF (CURRENT)*(PHASE FACTOR) OVER SEGMENT AND IMAGE FOR
C     CONSTANT, SINE, AND COSINE CURRENT DISTRIBUTIONS
C
      RFL=-1.
      DO 16  K=1,2
      RFL=- RFL
      RIZ= RZ- Z( I)* RFL
      RXYZ= SQRT( RIX* RIX+ RIY* RIY+ RIZ* RIZ)
      RNX= RIX/ RXYZ
      RNY= RIY/ RXYZ
      RNZ= RIZ/ RXYZ
      OMEGA=-( RNX* DX+ RNY* DY+ RNZ* DZ* RFL)
      SILL= OMEGA* EL
      TOP= EL+ SILL
      BOT= EL- SILL
      IF( ABS( OMEGA).LT.1.D-7) GOTO 9
      A=2.* SIN( SILL)/ OMEGA
      GOTO 10
    9 A=(2.- OMEGA* OMEGA* EL* EL/3.)* EL
   10 IF( ABS( TOP).LT.1.D-7) GOTO 11
      TOO= SIN( TOP)/ TOP
      GOTO 12
   11 TOO=1.- TOP* TOP/6.
   12 IF( ABS( BOT).LT.1.D-7) GOTO 13
      BOO= SIN( BOT)/ BOT
      GOTO 14
   13 BOO=1.- BOT* BOT/6.
   14 B= EL*( BOO- TOO)
      C= EL*( BOO+ TOO)
      RR= A* AIR( I)+ B* BII( I)+ C* CIR( I)
      RI= A* AII( I)- B* BIR( I)+ C* CII( I)
      ARG= TP*( X( I)* RNX+ Y( I)* RNY+ Z( I)* RNZ* RFL)
      EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI)/ TP
      IF( K.EQ.2) GOTO 15
      XX1= EXA
      R1= RXYZ
      ZMH= RIZ
      GOTO 16
   15 XX2= EXA
      R2= RXYZ
      ZPH= RIZ
C
C     CALL SUBROUTINE TO COMPUTE THE FIELD OF SEGMENT INCLUDING GROUND
C     WAVE.
C
   16 CONTINUE
      CALL GWAVE( ERV, EZV, ERH, EZH, EPH)
      ERH= ERH* CPH* CALP+ ERV* DZ
      EPH= EPH* SPH* CALP
      EZH= EZH* CPH* CALP+ EZV* DZ
      EX= ERH* RHX- EPH* RHY
      EY= ERH* RHY+ EPH* RHX
      CIX= CIX+ EX
      CIY= CIY+ EY
   17 CIZ= CIZ+ EZH
      ARG=- TP* R
      EXA= CMPLX( COS( ARG), SIN( ARG))
      CIX= CIX* EXA
      CIY= CIY* EXA
      CIZ= CIZ* EXA
      RNX= RX/ R
      RNY= RY/ R
      RNZ= RZ/ R
      THX= RNZ* PHY
      THY=- RNZ* PHX
      THZ=- RHO/ R
      ETH= CIX* THX+ CIY* THY+ CIZ* THZ
      EPI= CIX* PHX+ CIY* PHY
      ERD= CIX* RNX+ CIY* RNY+ CIZ* RNZ
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE GFOUT
C ***
C
C     WRITE N.G.F. FILE
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CM, SSX, ZRATI, ZRATI2, T1, ZARRAY, AR1, AR2, AR3,
     &EPSCF, FRATI
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /CMB/ CM(90000)
      COMMON  /ANGL/ SALP( NM)
      COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
     &KSYMP, IFAR, IPERF, T1, T2
      COMMON  /GGRID/ AR1(11,10,4), AR2(17,5,4), AR3(9,8,4), EPSCF, DXA
     &(3), DYA(3), XSA(3), YSA(3), NXA(3), NYA(3)
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      COMMON  /SMAT/ SSX(16,16)
      COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
      COMMON  /SAVE/ IP( N2M), KCOM, COM(19,5), EPSR, SIG, SCRWLT,
     &SCRWRT, FMHZ
      DATA   IGFL/20/
      NEQ= N+2* M
      NPEQ= NP+2* MP
      NOP= NEQ/ NPEQ
      WRITE( IGFL)  N, NP, M, MP, WLAM, FMHZ, IPSYM, KSYMP, IPERF,
     &NRADL, EPSR, SIG, SCRWLT, SCRWRT, NLOAD, KCOM
      IF( N.EQ.0) GOTO 1
      WRITE( IGFL) ( X( I), I=1, N),( Y( I), I=1, N),( Z( I), I=1, N)
      WRITE( IGFL) ( SI( I), I=1, N),( BI( I), I=1, N),( ALP( I), I=1,
     &N)
      WRITE( IGFL) ( BET( I), I=1, N),( SALP( I), I=1, N)
      WRITE( IGFL) ( ICON1( I), I=1, N),( ICON2( I), I=1, N)
      WRITE( IGFL) ( ITAG( I), I=1, N)
      IF( NLOAD.GT.0) WRITE( IGFL) ( ZARRAY( I), I=1, N)
    1 IF( M.EQ.0) GOTO 2
      J= LD- M+1
      WRITE( IGFL) ( X( I), I= J, LD),( Y( I), I= J, LD),( Z( I), I= J,
     & LD)
      WRITE( IGFL) ( SI( I), I= J, LD),( BI( I), I= J, LD),( ALP( I), I
     &= J, LD)
      WRITE( IGFL) ( BET( I), I= J, LD),( SALP( I), I= J, LD)
      WRITE( IGFL) ( ICON1( I), I= J, LD),( ICON2( I), I= J, LD)
      WRITE( IGFL) ( ITAG( I), I= J, LD)
    2 WRITE( IGFL)  ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, NLSYM,
     &IMAT
      IF( IPERF.EQ.2) WRITE( IGFL)  AR1, AR2, AR3, EPSCF, DXA, DYA, XSA
     &, YSA, NXA, NYA
      IF( NOP.GT.1) WRITE( IGFL) (( SSX( I, J), I=1, NOP), J=1, NOP)
      WRITE( IGFL) ( IP( I), I=1, NEQ), COM
      IF( ICASE.GT.2) GOTO 3
      IOUT= NEQ* NPEQ
      WRITE( IGFL) ( CM( I), I=1, IOUT)
      GOTO 12
    3 IF( ICASE.NE.4) GOTO 5
      REWIND 13
      I= NPEQ* NPEQ
      DO 4  K=1, NOP
      READ( 13) ( CM( J), J=1, I)
    4 WRITE( IGFL) ( CM( J), J=1, I)
      REWIND 13
      GOTO 12
    5 REWIND 13
      REWIND 14
      IF( ICASE.EQ.5) GOTO 8
      IOUT= NPBLK* NEQ*2
      DO 6  I=1, NBLOKS
      CALL BLCKIN( CM,13,1, IOUT,1,201)
    6 CALL BLCKOT( CM, IGFL,1, IOUT,1,202)
      DO 7  I=1, NBLOKS
      CALL BLCKIN( CM,14,1, IOUT,1,203)
    7 CALL BLCKOT( CM, IGFL,1, IOUT,1,204)
      GOTO 12
    8 IOUT= NPSYM* NPEQ*2
      DO 11  IOP=1, NOP
      DO 9  I=1, NBLSYM
      CALL BLCKIN( CM,13,1, IOUT,1,205)
    9 CALL BLCKOT( CM, IGFL,1, IOUT,1,206)
      DO 10  I=1, NBLSYM
      CALL BLCKIN( CM,14,1, IOUT,1,207)
   10 CALL BLCKOT( CM, IGFL,1, IOUT,1,208)
   11 CONTINUE
      REWIND 13
      REWIND 14
   12 REWIND IGFL
      WRITE( 6,13)  IGFL, IMAT
C
      RETURN
   13 FORMAT(///,' ****NUMERICAL GREEN S FUNCTION FILE ON TAPE',I3,
     &'****',/,5X,'MATRIX STORAGE -',I7,' COMPLEX NUMBERS',///)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE GH( ZK, HR, HI)
C ***
C     INTEGRAND FOR H FIELD OF A WIRE
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /TMH/ ZPK, RHKS
      RS= ZK- ZPK
      RS= RHKS+ RS* RS
      R= SQRT( RS)
      CKR= COS( R)
      SKR= SIN( R)
      RR2=1./ RS
      RR3= RR2/ R
      HR= SKR* RR2+ CKR* RR3
      HI= CKR* RR2- SKR* RR3
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE GWAVE( ERV, EZV, ERH, EZH, EPH)
C ***
C
C     GWAVE COMPUTES THE ELECTRIC FIELD, INCLUDING GROUND WAVE, OF A
C     CURRENT ELEMENT OVER A GROUND PLANE USING FORMULAS OF K.A. NORTON
C     (PROC. IRE, SEPT., 1937, PP.1203,1236.)
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  FJ, TPJ, U2, U, RK1, RK2, T1, T2, T3, T4, P1, RV, OMR
     &, W, F, Q1, RH, V, G, XR1, XR2, X1, X2, X3, X4, X5, X6, X7, EZV,
     &ERV, EZH, ERH, EPH, XX1, XX2, ECON, FBAR
      COMMON  /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH
      DIMENSION  FJX(2), TPJX(2), ECONX(2)
      EQUIVALENCE(FJ,FJX),(TPJ,TPJX),(ECON,ECONX)
      DATA   PI/3.141592654D+0/, FJX/0.,1./, TPJX/0.,6.283185308D+0/
      DATA   ECONX/0.,-188.367/
      SPPP= ZMH/ R1
      SPPP2= SPPP* SPPP
      CPPP2=1.- SPPP2
      IF( CPPP2.LT.1.D-20) CPPP2=1.D-20
      CPPP= SQRT( CPPP2)
      SPP= ZPH/ R2
      SPP2= SPP* SPP
      CPP2=1.- SPP2
      IF( CPP2.LT.1.D-20) CPP2=1.D-20
      CPP= SQRT( CPP2)
      RK1=- TPJ* R1
      RK2=- TPJ* R2
      T1=1.- U2* CPP2
      T2= SQRT( T1)
      T3=(1.-1./ RK1)/ RK1
      T4=(1.-1./ RK2)/ RK2
      P1= RK2* U2* T1/(2.* CPP2)
      RV=( SPP- U* T2)/( SPP+ U* T2)
      OMR=1.- RV
      W=1./ OMR
      W=(4.,0.)* P1* W* W
      F= FBAR( W)
      Q1= RK2* T1/(2.* U2* CPP2)
      RH=( T2- U* SPP)/( T2+ U* SPP)
      V=1./(1.+ RH)
      V=(4.,0.)* Q1* V* V
      G= FBAR( V)
      XR1= XX1/ R1
      XR2= XX2/ R2
      X1= CPPP2* XR1
      X2= RV* CPP2* XR2
      X3= OMR* CPP2* F* XR2
      X4= U* T2* SPP*2.* XR2/ RK2
      X5= XR1* T3*(1.-3.* SPPP2)
      X6= XR2* T4*(1.-3.* SPP2)
      EZV=( X1+ X2+ X3- X4- X5- X6)* ECON
      X1= SPPP* CPPP* XR1
      X2= RV* SPP* CPP* XR2
      X3= CPP* OMR* U* T2* F* XR2
      X4= SPP* CPP* OMR* XR2/ RK2
      X5=3.* SPPP* CPPP* T3* XR1
      X6= CPP* U* T2* OMR* XR2/ RK2*.5
      X7=3.* SPP* CPP* T4* XR2
      ERV=-( X1+ X2- X3+ X4- X5+ X6- X7)* ECON
      EZH=-( X1- X2+ X3- X4- X5- X6+ X7)* ECON
      X1= SPPP2* XR1
      X2= RV* SPP2* XR2
      X4= U2* T1* OMR* F* XR2
      X5= T3*(1.-3.* CPPP2)* XR1
      X6= T4*(1.-3.* CPP2)*(1.- U2*(1.+ RV)- U2* OMR* F)* XR2
      X7= U2* CPP2* OMR*(1.-1./ RK2)*( F*( U2* T1- SPP2-1./ RK2)+1./
     &RK2)* XR2
      ERH=( X1- X2- X4- X5+ X6+ X7)* ECON
      X1= XR1
      X2= RH* XR2
      X3=( RH+1.)* G* XR2
      X4= T3* XR1
      X5= T4*(1.- U2*(1.+ RV)- U2* OMR* F)* XR2
      X6=.5* U2* OMR*( F*( U2* T1- SPP2-1./ RK2)+1./ RK2)* XR2/ RK2
      EPH=-( X1- X2+ X3- X4+ X5+ X6)* ECON
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE GX( ZZ, RH, XK, GZ, GZP)
C ***
C     SEGMENT END CONTRIBUTIONS FOR THIN WIRE APPROX.
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  GZ, GZP
      R2= ZZ* ZZ+ RH* RH
      R= SQRT( R2)
      RKZ= XK* R
      GZ= CMPLX( COS( RKZ),- SIN( RKZ))/ R
      GZP=- CMPLX(1.0, RKZ)* GZ/ R2
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE GXX( ZZ, RH, A, A2, XK, IRA, G1, G1P, G2, G2P, G3, GZP
     &)
C ***
C     SEGMENT END CONTRIBUTIONS FOR EXT. THIN WIRE APPROX.
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  GZ, C1, C2, C3, G1, G1P, G2, G2P, G3, GZP
      R2= ZZ* ZZ+ RH* RH
      R= SQRT( R2)
      R4= R2* R2
      RK= XK* R
      RK2= RK* RK
      RH2= RH* RH
      T1=.25* A2* RH2/ R4
      T2=.5* A2/ R2
      C1= CMPLX(1.0, RK)
      C2=3.* C1- RK2
      C3= CMPLX(6.0, RK)* RK2-15.* C1
      GZ= CMPLX( COS( RK),- SIN( RK))/ R
      G2= GZ*(1.+ T1* C2)
      G1= G2- T2* C1* GZ
      GZ= GZ/ R2
      G2P= GZ*( T1* C3- C1)
      GZP= T2* C2* GZ
      G3= G2P+ GZP
      G1P= G3* ZZ
      IF( IRA.EQ.1) GOTO 2
      G3=( G3+ GZP)* RH
      GZP=- ZZ* C1* GZ
      IF( RH.GT.1.D-10) GOTO 1
      G2=0.
      G2P=0.
      RETURN
    1 G2= G2/ RH
      G2P= G2P* ZZ/ RH
      RETURN
    2 T2=.5* A
      G2=- T2* C1* GZ
      G2P= T2* GZ* C2/ R2
      G3= RH2* G2P- A* GZ* C1
      G2P= G2P* ZZ
      GZP=- ZZ* C1* GZ
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE HELIX( S, HL, A1, B1, A2, B2, RAD, NS, ITG)
C ***
C     SUBROUTINE HELIX GENERATES SEGMENT GEOMETRY DATA FOR A HELIX OF NS
C     SEGMENTS
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      DIMENSION  X2(1), Y2(1), Z2(1)
      EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1))
      DATA   PI/3.1415926D+0/
      IST= N+1
      N= N+ NS
      NP= N
      MP= M
      IPSYM=0
      IF( NS.LT.1) RETURN
      TURNS= ABS( HL/ S)
      ZINC= ABS( HL/ NS)
      Z( IST)=0.
      DO 25  I= IST, N
      BI( I)= RAD
      ITAG( I)= ITG
      IF( I.NE. IST) Z( I)= Z( I-1)+ ZINC
      Z2( I)= Z( I)+ ZINC
      IF( A2.NE. A1) GOTO 10
      IF( B1.EQ.0) B1= A1
      X( I)= A1* COS(2.* PI* Z( I)/ S)
      Y( I)= B1* SIN(2.* PI* Z( I)/ S)
      X2( I)= A1* COS(2.* PI* Z2( I)/ S)
      Y2( I)= B1* SIN(2.* PI* Z2( I)/ S)
      GOTO 20
   10 IF( B2.EQ.0) B2= A2
      X( I)=( A1+( A2- A1)* Z( I)/ ABS( HL))* COS(2.* PI* Z( I)/ S)
      Y( I)=( B1+( B2- B1)* Z( I)/ ABS( HL))* SIN(2.* PI* Z( I)/ S)
      X2( I)=( A1+( A2- A1)* Z2( I)/ ABS( HL))* COS(2.* PI* Z2( I)/ S)
      Y2( I)=( B1+( B2- B1)* Z2( I)/ ABS( HL))* SIN(2.* PI* Z2( I)/ S)
   20 IF( HL.GT.0) GOTO 25
      COPY= X( I)
      X( I)= Y( I)
      Y( I)= COPY
      COPY= X2( I)
      X2( I)= Y2( I)
      Y2( I)= COPY
   25 CONTINUE
      IF( A2.EQ. A1) GOTO 21
      SANGLE= ATAN( A2/( ABS( HL)+( ABS( HL)* A1)/( A2- A1)))
      WRITE( 6,104)  SANGLE
  104 FORMAT(5X,'THE CONE ANGLE OF THE SPIRAL IS',F10.4)
      RETURN
   21 IF( A1.NE. B1) GOTO 30
      HDIA=2.* A1
      TURN= HDIA* PI
      PITCH= ATAN( S/( PI* HDIA))
      TURN= TURN/ COS( PITCH)
      PITCH=180.* PITCH/ PI
      GOTO 40
   30 IF( A1.LT. B1) GOTO 34
      HMAJ=2.* A1
      HMIN=2.* B1
      GOTO 35
   34 HMAJ=2.* B1
      HMIN=2.* A1
   35 HDIA= SQRT(( HMAJ**2+ HMIN**2)/2* HMAJ)
      TURN=2.* PI* HDIA
      PITCH=(180./ PI)* ATAN( S/( PI* HDIA))
   40 WRITE( 6,105)  PITCH, TURN
  105 FORMAT(5X,'THE PITCH ANGLE IS',F10.4/5X,
     &'THE LENGTH OF WIRE/TURN ''IS',F10.4)
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE HFK( EL1, EL2, RHK, ZPKX, SGR, SGI)
C ***
C     HFK COMPUTES THE H FIELD OF A UNIFORM CURRENT FILAMENT BY
C     NUMERICAL INTEGRATION
      IMPLICIT REAL (A-H,O-Z)
      COMMON  /TMH/ ZPK, RHKS
      DATA   NX, NM, NTS, RX/1,65536,4,1.D-4/
      ZPK= ZPKX
      RHKS= RHK* RHK
      Z= EL1
      ZE= EL2
      S= ZE- Z
      EP= S/(10.* NM)
      ZEND= ZE- EP
      SGR=0.0
      SGI=0.0
      NS= NX
      NT=0
      CALL GH( Z, G1R, G1I)
    1 DZ= S/ NS
      ZP= Z+ DZ
      IF( ZP- ZE) 3,3,2
    2 DZ= ZE- Z
      IF( ABS( DZ)- EP) 17,17,3
    3 DZOT= DZ*.5
      ZP= Z+ DZOT
      CALL GH( ZP, G3R, G3I)
      ZP= Z+ DZ
      CALL GH( ZP, G5R, G5I)
    4 T00R=( G1R+ G5R)* DZOT
      T00I=( G1I+ G5I)* DZOT
      T01R=( T00R+ DZ* G3R)*0.5
      T01I=( T00I+ DZ* G3I)*0.5
      T10R=(4.0* T01R- T00R)/3.0
      T10I=(4.0* T01I- T00I)/3.0
      CALL TEST( T01R, T10R, TE1R, T01I, T10I, TE1I,0.)
      IF( TE1I- RX) 5,5,6
    5 IF( TE1R- RX) 8,8,6
    6 ZP= Z+ DZ*0.25
      CALL GH( ZP, G2R, G2I)
      ZP= Z+ DZ*0.75
      CALL GH( ZP, G4R, G4I)
      T02R=( T01R+ DZOT*( G2R+ G4R))*0.5
      T02I=( T01I+ DZOT*( G2I+ G4I))*0.5
      T11R=(4.0* T02R- T01R)/3.0
      T11I=(4.0* T02I- T01I)/3.0
      T20R=(16.0* T11R- T10R)/15.0
      T20I=(16.0* T11I- T10I)/15.0
      CALL TEST( T11R, T20R, TE2R, T11I, T20I, TE2I,0.)
      IF( TE2I- RX) 7,7,14
    7 IF( TE2R- RX) 9,9,14
    8 SGR= SGR+ T10R
      SGI= SGI+ T10I
      NT= NT+2
      GOTO 10
    9 SGR= SGR+ T20R
      SGI= SGI+ T20I
      NT= NT+1
   10 Z= Z+ DZ
      IF( Z- ZEND) 11,17,17
   11 G1R= G5R
      G1I= G5I
      IF( NT- NTS) 1,12,12
   12 IF( NS- NX) 1,1,13
   13 NS= NS/2
      NT=1
      GOTO 1
   14 NT=0
      IF( NS- NM) 16,15,15
   15 WRITE( 6,18)  Z
      GOTO 9
   16 NS= NS*2
      DZ= S/ NS
      DZOT= DZ*0.5
      G5R= G3R
      G5I= G3I
      G3R= G2R
      G3I= G2I
      GOTO 4
   17 CONTINUE
      SGR= SGR* RHK*.5
      SGI= SGI* RHK*.5
C
      RETURN
   18 FORMAT(' STEP SIZE LIMITED AT Z=',F10.5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE HINTG( XI, YI, ZI)
C ***
C     HINTG COMPUTES THE H FIELD OF A PATCH CURRENT
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, ZRATI,
     &ZRATI2, GAM, F1X, F1Y, F1Z, F2X, F2Y, F2Z, RRV, RRH, T1, FRATI
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
     &KSYMP, IFAR, IPERF, T1, T2
      EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
     &IND1),(T2ZJ,IND2)
      DATA   FPI/12.56637062D+0/, TP/6.283185308D+0/
      RX= XI- XJ
      RY= YI- YJ
      RFL=-1.
      EXK=(0.,0.)
      EYK=(0.,0.)
      EZK=(0.,0.)
      EXS=(0.,0.)
      EYS=(0.,0.)
      EZS=(0.,0.)
      DO 5  IP=1, KSYMP
      RFL=- RFL
      RZ= ZI- ZJ* RFL
      RSQ= RX* RX+ RY* RY+ RZ* RZ
      IF( RSQ.LT.1.D-20) GOTO 5
      R= SQRT( RSQ)
      RK= TP* R
      CR= COS( RK)
      SR= SIN( RK)
      GAM=-( CMPLX( CR,- SR)+ RK* CMPLX( SR, CR))/( FPI* RSQ* R)* S
      EXC= GAM* RX
      EYC= GAM* RY
      EZC= GAM* RZ
      T1ZR= T1ZJ* RFL
      T2ZR= T2ZJ* RFL
      F1X= EYC* T1ZR- EZC* T1YJ
      F1Y= EZC* T1XJ- EXC* T1ZR
      F1Z= EXC* T1YJ- EYC* T1XJ
      F2X= EYC* T2ZR- EZC* T2YJ
      F2Y= EZC* T2XJ- EXC* T2ZR
      F2Z= EXC* T2YJ- EYC* T2XJ
      IF( IP.EQ.1) GOTO 4
      IF( IPERF.NE.1) GOTO 1
      F1X=- F1X
      F1Y=- F1Y
      F1Z=- F1Z
      F2X=- F2X
      F2Y=- F2Y
      F2Z=- F2Z
      GOTO 4
    1 XYMAG= SQRT( RX* RX+ RY* RY)
      IF( XYMAG.GT.1.D-6) GOTO 2
      PX=0.
      PY=0.
      CTH=1.
      RRV=(1.,0.)
      GOTO 3
    2 PX=- RY/ XYMAG
      PY= RX/ XYMAG
      CTH= RZ/ R
      RRV= SQRT(1.- ZRATI* ZRATI*(1.- CTH* CTH))
    3 RRH= ZRATI* CTH
      RRH=( RRH- RRV)/( RRH+ RRV)
      RRV= ZRATI* RRV
      RRV=-( CTH- RRV)/( CTH+ RRV)
      GAM=( F1X* PX+ F1Y* PY)*( RRV- RRH)
      F1X= F1X* RRH+ GAM* PX
      F1Y= F1Y* RRH+ GAM* PY
      F1Z= F1Z* RRH
      GAM=( F2X* PX+ F2Y* PY)*( RRV- RRH)
      F2X= F2X* RRH+ GAM* PX
      F2Y= F2Y* RRH+ GAM* PY
      F2Z= F2Z* RRH
    4 EXK= EXK+ F1X
      EYK= EYK+ F1Y
      EZK= EZK+ F1Z
      EXS= EXS+ F2X
      EYS= EYS+ F2Y
      EZS= EZS+ F2Z
    5 CONTINUE
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE HSFLD( XI, YI, ZI, AI)
C ***
C     HSFLD COMPUTES THE H FIELD FOR CONSTANT, SINE, AND COSINE CURRENT
C     ON A SEGMENT INCLUDING GROUND EFFECTS.
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, ZRATI,
     &ZRATI2, T1, HPK, HPS, HPC, QX, QY, QZ, RRV, RRH, ZRATX, FRATI
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
     &KSYMP, IFAR, IPERF, T1, T2
      DATA   ETA/376.73/
      XIJ= XI- XJ
      YIJ= YI- YJ
      RFL=-1.
      DO 7  IP=1, KSYMP
      RFL=- RFL
      SALPR= SALPJ* RFL
      ZIJ= ZI- RFL* ZJ
      ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR
      RHOX= XIJ- CABJ* ZP
      RHOY= YIJ- SABJ* ZP
      RHOZ= ZIJ- SALPR* ZP
      RH= SQRT( RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ+ AI* AI)
      IF( RH.GT.1.D-10) GOTO 1
      EXK=0.
      EYK=0.
      EZK=0.
      EXS=0.
      EYS=0.
      EZS=0.
      EXC=0.
      EYC=0.
      EZC=0.
      GOTO 7
    1 RHOX= RHOX/ RH
      RHOY= RHOY/ RH
      RHOZ= RHOZ/ RH
      PHX= SABJ* RHOZ- SALPR* RHOY
      PHY= SALPR* RHOX- CABJ* RHOZ
      PHZ= CABJ* RHOY- SABJ* RHOX
      CALL HSFLX( S, RH, ZP, HPK, HPS, HPC)
      IF( IP.NE.2) GOTO 6
      IF( IPERF.EQ.1) GOTO 5
      ZRATX= ZRATI
      RMAG= SQRT( ZP* ZP+ RH* RH)
C
C     SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN.
C
      XYMAG= SQRT( XIJ* XIJ+ YIJ* YIJ)
      IF( NRADL.EQ.0) GOTO 2
      XSPEC=( XI* ZJ+ ZI* XJ)/( ZI+ ZJ)
      YSPEC=( YI* ZJ+ ZI* YJ)/( ZI+ ZJ)
      RHOSPC= SQRT( XSPEC* XSPEC+ YSPEC* YSPEC+ T2* T2)
      IF( RHOSPC.GT. SCRWL) GOTO 2
      RRV= T1* RHOSPC* LOG( RHOSPC/ T2)
      ZRATX=( RRV* ZRATI)/( ETA* ZRATI+ RRV)
C
C     CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED.
C
    2 IF( XYMAG.GT.1.D-6) GOTO 3
      PX=0.
      PY=0.
      CTH=1.
      RRV=(1.,0.)
      GOTO 4
    3 PX=- YIJ/ XYMAG
      PY= XIJ/ XYMAG
      CTH= ZIJ/ RMAG
      RRV= SQRT(1.- ZRATX* ZRATX*(1.- CTH* CTH))
    4 RRH= ZRATX* CTH
      RRH=-( RRH- RRV)/( RRH+ RRV)
      RRV= ZRATX* RRV
      RRV=( CTH- RRV)/( CTH+ RRV)
      QY=( PHX* PX+ PHY* PY)*( RRV- RRH)
      QX= QY* PX+ PHX* RRH
      QY= QY* PY+ PHY* RRH
      QZ= PHZ* RRH
      EXK= EXK- HPK* QX
      EYK= EYK- HPK* QY
      EZK= EZK- HPK* QZ
      EXS= EXS- HPS* QX
      EYS= EYS- HPS* QY
      EZS= EZS- HPS* QZ
      EXC= EXC- HPC* QX
      EYC= EYC- HPC* QY
      EZC= EZC- HPC* QZ
      GOTO 7
    5 EXK= EXK- HPK* PHX
      EYK= EYK- HPK* PHY
      EZK= EZK- HPK* PHZ
      EXS= EXS- HPS* PHX
      EYS= EYS- HPS* PHY
      EZS= EZS- HPS* PHZ
      EXC= EXC- HPC* PHX
      EYC= EYC- HPC* PHY
      EZC= EZC- HPC* PHZ
      GOTO 7
    6 EXK= HPK* PHX
      EYK= HPK* PHY
      EZK= HPK* PHZ
      EXS= HPS* PHX
      EYS= HPS* PHY
      EZS= HPS* PHZ
      EXC= HPC* PHX
      EYC= HPC* PHY
      EZC= HPC* PHZ
    7 CONTINUE
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE HSFLX( S, RH, ZPX, HPK, HPS, HPC)
C ***
C     CALCULATES H FIELD OF SINE COSINE, AND CONSTANT CURRENT OF SEGMENT
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  FJ, FJK, EKR1, EKR2, T1, T2, CONS, HPS, HPC, HPK
      DIMENSION  FJX(2), FJKX(2)
      EQUIVALENCE(FJ,FJX),(FJK,FJKX)
      DATA   TP/6.283185308D+0/, FJX/0.,1./, FJKX/0.,-6.283185308D+0/
      DATA   PI8/25.13274123D+0/
      IF( RH.LT.1.D-10) GOTO 6
      IF( ZPX.LT.0.) GOTO 1
      ZP= ZPX
      HSS=1.
      GOTO 2
    1 ZP=- ZPX
      HSS=-1.
    2 DH=.5* S
      Z1= ZP+ DH
      Z2= ZP- DH
      IF( Z2.LT.1.D-7) GOTO 3
      RHZ= RH/ Z2
      GOTO 4
    3 RHZ=1.
    4 DK= TP* DH
      CDK= COS( DK)
      SDK= SIN( DK)
      CALL HFK(- DK, DK, RH* TP, ZP* TP, HKR, HKI)
      HPK= CMPLX( HKR, HKI)
      IF( RHZ.LT.1.D-3) GOTO 5
      RH2= RH* RH
      R1= SQRT( RH2+ Z1* Z1)
      R2= SQRT( RH2+ Z2* Z2)
      EKR1= EXP( FJK* R1)
      EKR2= EXP( FJK* R2)
      T1= Z1* EKR1/ R1
      T2= Z2* EKR2/ R2
      HPS=( CDK*( EKR2- EKR1)- FJ* SDK*( T2+ T1))* HSS
      HPC=- SDK*( EKR2+ EKR1)- FJ* CDK*( T2- T1)
      CONS=- FJ/(2.* TP* RH)
      HPS= CONS* HPS
      HPC= CONS* HPC
      RETURN
    5 EKR1= CMPLX( CDK, SDK)/( Z2* Z2)
      EKR2= CMPLX( CDK,- SDK)/( Z1* Z1)
      T1= TP*(1./ Z1-1./ Z2)
      T2= EXP( FJK* ZP)* RH/ PI8
      HPS= T2*( T1+( EKR1+ EKR2)* SDK)* HSS
      HPC= T2*(- FJ* T1+( EKR1- EKR2)* CDK)
      RETURN
    6 HPS=(0.,0.)
      HPC=(0.,0.)
      HPK=(0.,0.)
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE INTRP( X, Y, F1, F2, F3, F4)
C ***
C
C     INTRP USES BIVARIATE CUBIC INTERPOLATION TO OBTAIN THE VALUES OF
C     4 FUNCTIONS AT THE POINT (X,Y).
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  F1, F2, F3, F4, A, B, C, D, FX1, FX2, FX3, FX4, P1,
     &P2, P3, P4, A11, A12, A13, A14, A21, A22, A23, A24, A31, A32, A33
     &, A34, A41, A42, A43, A44, B11, B12, B13, B14, B21, B22, B23, B24
     &, B31, B32, B33, B34, B41, B42, B43, B44, C11, C12, C13, C14, C21
     &, C22, C23, C24, C31, C32, C33, C34, C41, C42, C43, C44, D11, D12
     &, D13, D14, D21, D22, D23, D24, D31, D32, D33, D34, D41, D42, D43
     &, D44
      COMPLEX  AR1, AR2, AR3, ARL1, ARL2, ARL3, EPSCF
      COMMON  /GGRID/ AR1(11,10,4), AR2(17,5,4), AR3(9,8,4), EPSCF, DXA
     &(3), DYA(3), XSA(3), YSA(3), NXA(3), NYA(3)
      DIMENSION  NDA(3), NDPA(3)
      DIMENSION  A(4,4), B(4,4), C(4,4), D(4,4), ARL1(1), ARL2(1), ARL3
     &(1)
      EQUIVALENCE(A(1,1),A11),(A(1,2),A12),(A(1,3),A13),(A(1,4),A14)
      EQUIVALENCE(A(2,1),A21),(A(2,2),A22),(A(2,3),A23),(A(2,4),A24)
      EQUIVALENCE(A(3,1),A31),(A(3,2),A32),(A(3,3),A33),(A(3,4),A34)
      EQUIVALENCE(A(4,1),A41),(A(4,2),A42),(A(4,3),A43),(A(4,4),A44)
      EQUIVALENCE(B(1,1),B11),(B(1,2),B12),(B(1,3),B13),(B(1,4),B14)
      EQUIVALENCE(B(2,1),B21),(B(2,2),B22),(B(2,3),B23),(B(2,4),B24)
      EQUIVALENCE(B(3,1),B31),(B(3,2),B32),(B(3,3),B33),(B(3,4),B34)
      EQUIVALENCE(B(4,1),B41),(B(4,2),B42),(B(4,3),B43),(B(4,4),B44)
      EQUIVALENCE(C(1,1),C11),(C(1,2),C12),(C(1,3),C13),(C(1,4),C14)
      EQUIVALENCE(C(2,1),C21),(C(2,2),C22),(C(2,3),C23),(C(2,4),C24)
      EQUIVALENCE(C(3,1),C31),(C(3,2),C32),(C(3,3),C33),(C(3,4),C34)
      EQUIVALENCE(C(4,1),C41),(C(4,2),C42),(C(4,3),C43),(C(4,4),C44)
      EQUIVALENCE(D(1,1),D11),(D(1,2),D12),(D(1,3),D13),(D(1,4),D14)
      EQUIVALENCE(D(2,1),D21),(D(2,2),D22),(D(2,3),D23),(D(2,4),D24)
      EQUIVALENCE(D(3,1),D31),(D(3,2),D32),(D(3,3),D33),(D(3,4),D34)
      EQUIVALENCE(D(4,1),D41),(D(4,2),D42),(D(4,3),D43),(D(4,4),D44)
      EQUIVALENCE(ARL1,AR1),(ARL2,AR2),(ARL3,AR3),(XS2,XSA(2)),(YS3,YSA
     &(3))
      DATA   IXS, IYS, IGRS/-10,-10,-10/, DX, DY, XS, YS/1.,1.,0.,0./
      DATA   NDA/11,17,9/, NDPA/110,85,72/, IXEG, IYEG/0,0/
      IF( X.LT. XS.OR. Y.LT. YS) GOTO 1
      IX= INT(( X- XS)/ DX)+1
C
C     IF POINT LIES IN SAME 4 BY 4 POINT REGION AS PREVIOUS POINT, OLD
C     VALUES ARE REUSED
C
      IY= INT(( Y- YS)/ DY)+1
      IF( IX.LT. IXEG.OR. IY.LT. IYEG) GOTO 1
C
C     DETERMINE CORRECT GRID AND GRID REGION
C
      IF( IABS( IX- IXS).LT.2.AND. IABS( IY- IYS).LT.2) GOTO 12
    1 IF( X.GT. XS2) GOTO 2
      IGR=1
      GOTO 3
    2 IGR=2
      IF( Y.GT. YS3) IGR=3
    3 IF( IGR.EQ. IGRS) GOTO 4
      IGRS= IGR
      DX= DXA( IGRS)
      DY= DYA( IGRS)
      XS= XSA( IGRS)
      YS= YSA( IGRS)
      NXM2= NXA( IGRS)-2
      NYM2= NYA( IGRS)-2
      NXMS=(( NXM2+1)/3)*3+1
      NYMS=(( NYM2+1)/3)*3+1
      ND= NDA( IGRS)
      NDP= NDPA( IGRS)
      IX= INT(( X- XS)/ DX)+1
      IY= INT(( Y- YS)/ DY)+1
    4 IXS=(( IX-1)/3)*3+2
      IF( IXS.LT.2) IXS=2
      IXEG=-10000
      IF( IXS.LE. NXM2) GOTO 5
      IXS= NXM2
      IXEG= NXMS
    5 IYS=(( IY-1)/3)*3+2
      IF( IYS.LT.2) IYS=2
      IYEG=-10000
      IF( IYS.LE. NYM2) GOTO 6
      IYS= NYM2
C
C     COMPUTE COEFFICIENTS OF 4 CUBIC POLYNOMIALS IN X FOR THE 4 GRID
C     VALUES OF Y FOR EACH OF THE 4 FUNCTIONS
C
      IYEG= NYMS
    6 IADZ= IXS+( IYS-3)* ND- NDP
      DO 11  K=1,4
      IADZ= IADZ+ NDP
      IADD= IADZ
      DO 11  I=1,4
      IADD= IADD+ ND
C     P1=AR1(IXS-1,IYS-2+I,K)
      GOTO (7,8,9), IGRS
    7 P1= ARL1( IADD-1)
      P2= ARL1( IADD)
      P3= ARL1( IADD+1)
      P4= ARL1( IADD+2)
      GOTO 10
    8 P1= ARL2( IADD-1)
      P2= ARL2( IADD)
      P3= ARL2( IADD+1)
      P4= ARL2( IADD+2)
      GOTO 10
    9 P1= ARL3( IADD-1)
      P2= ARL3( IADD)
      P3= ARL3( IADD+1)
      P4= ARL3( IADD+2)
   10 A( I, K)=( P4- P1+3.*( P2- P3))*.1666666667D+0
      B( I, K)=( P1-2.* P2+ P3)*.5
      C( I, K)= P3-(2.* P1+3.* P2+ P4)*.1666666667D+0
   11 D( I, K)= P2
      XZ=( IXS-1)* DX+ XS
C
C     EVALUATE POLYMOMIALS IN X AND THEN USE CUBIC INTERPOLATION IN Y
C     FOR EACH OF THE 4 FUNCTIONS.
C
      YZ=( IYS-1)* DY+ YS
   12 XX=( X- XZ)/ DX
      YY=( Y- YZ)/ DY
      FX1=(( A11* XX+ B11)* XX+ C11)* XX+ D11
      FX2=(( A21* XX+ B21)* XX+ C21)* XX+ D21
      FX3=(( A31* XX+ B31)* XX+ C31)* XX+ D31
      FX4=(( A41* XX+ B41)* XX+ C41)* XX+ D41
      P1= FX4- FX1+3.*( FX2- FX3)
      P2=3.*( FX1-2.* FX2+ FX3)
      P3=6.* FX3-2.* FX1-3.* FX2- FX4
      F1=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2
      FX1=(( A12* XX+ B12)* XX+ C12)* XX+ D12
      FX2=(( A22* XX+ B22)* XX+ C22)* XX+ D22
      FX3=(( A32* XX+ B32)* XX+ C32)* XX+ D32
      FX4=(( A42* XX+ B42)* XX+ C42)* XX+ D42
      P1= FX4- FX1+3.*( FX2- FX3)
      P2=3.*( FX1-2.* FX2+ FX3)
      P3=6.* FX3-2.* FX1-3.* FX2- FX4
      F2=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2
      FX1=(( A13* XX+ B13)* XX+ C13)* XX+ D13
      FX2=(( A23* XX+ B23)* XX+ C23)* XX+ D23
      FX3=(( A33* XX+ B33)* XX+ C33)* XX+ D33
      FX4=(( A43* XX+ B43)* XX+ C43)* XX+ D43
      P1= FX4- FX1+3.*( FX2- FX3)
      P2=3.*( FX1-2.* FX2+ FX3)
      P3=6.* FX3-2.* FX1-3.* FX2- FX4
      F3=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2
      FX1=(( A14* XX+ B14)* XX+ C14)* XX+ D14
      FX2=(( A24* XX+ B24)* XX+ C24)* XX+ D24
      FX3=(( A34* XX+ B34)* XX+ C34)* XX+ D34
      FX4=(( A44* XX+ B44)* XX+ C44)* XX+ D44
      P1= FX4- FX1+3.*( FX2- FX3)
      P2=3.*( FX1-2.* FX2+ FX3)
      P3=6.* FX3-2.* FX1-3.* FX2- FX4
      F4=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE INTX( EL1, EL2, B, IJ, SGR, SGI)
C ***
C
C     INTX PERFORMS NUMERICAL INTEGRATION OF EXP(JKR)/R BY THE METHOD OF
C     VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION.  THE INTEGRAND VALUE
C     IS SUPPLIED BY SUBROUTINE GF.
C
      IMPLICIT REAL (A-H,O-Z)
      DATA   NX, NM, NTS, RX/1,65536,4,1.D-4/
      Z= EL1
      ZE= EL2
      IF( IJ.EQ.0) ZE=0.
      S= ZE- Z
      FNM= NM
      EP= S/(10.* FNM)
      ZEND= ZE- EP
      SGR=0.
      SGI=0.
      NS= NX
      NT=0
      CALL GF( Z, G1R, G1I)
    1 FNS= NS
      DZ= S/ FNS
      ZP= Z+ DZ
      IF( ZP- ZE) 3,3,2
    2 DZ= ZE- Z
      IF( ABS( DZ)- EP) 17,17,3
    3 DZOT= DZ*.5
      ZP= Z+ DZOT
      CALL GF( ZP, G3R, G3I)
      ZP= Z+ DZ
      CALL GF( ZP, G5R, G5I)
    4 T00R=( G1R+ G5R)* DZOT
      T00I=( G1I+ G5I)* DZOT
      T01R=( T00R+ DZ* G3R)*0.5
      T01I=( T00I+ DZ* G3I)*0.5
      T10R=(4.0* T01R- T00R)/3.0
C
C     TEST CONVERGENCE OF 3 POINT ROMBERG RESULT.
C
      T10I=(4.0* T01I- T00I)/3.0
      CALL TEST( T01R, T10R, TE1R, T01I, T10I, TE1I,0.)
      IF( TE1I- RX) 5,5,6
    5 IF( TE1R- RX) 8,8,6
    6 ZP= Z+ DZ*0.25
      CALL GF( ZP, G2R, G2I)
      ZP= Z+ DZ*0.75
      CALL GF( ZP, G4R, G4I)
      T02R=( T01R+ DZOT*( G2R+ G4R))*0.5
      T02I=( T01I+ DZOT*( G2I+ G4I))*0.5
      T11R=(4.0* T02R- T01R)/3.0
      T11I=(4.0* T02I- T01I)/3.0
      T20R=(16.0* T11R- T10R)/15.0
C
C     TEST CONVERGENCE OF 5 POINT ROMBERG RESULT.
C
      T20I=(16.0* T11I- T10I)/15.0
      CALL TEST( T11R, T20R, TE2R, T11I, T20I, TE2I,0.)
      IF( TE2I- RX) 7,7,14
    7 IF( TE2R- RX) 9,9,14
    8 SGR= SGR+ T10R
      SGI= SGI+ T10I
      NT= NT+2
      GOTO 10
    9 SGR= SGR+ T20R
      SGI= SGI+ T20I
      NT= NT+1
   10 Z= Z+ DZ
      IF( Z- ZEND) 11,17,17
   11 G1R= G5R
      G1I= G5I
      IF( NT- NTS) 1,12,12
C
C     DOUBLE STEP SIZE
C
   12 IF( NS- NX) 1,1,13
   13 NS= NS/2
      NT=1
      GOTO 1
   14 NT=0
      IF( NS- NM) 16,15,15
   15 WRITE( 6,20)  Z
C
C     HALVE STEP SIZE
C
      GOTO 9
   16 NS= NS*2
      FNS= NS
      DZ= S/ FNS
      DZOT= DZ*0.5
      G5R= G3R
      G5I= G3I
      G3R= G2R
      G3I= G2I
      GOTO 4
   17 CONTINUE
C
C     ADD CONTRIBUTION OF NEAR SINGULARITY FOR DIAGONAL TERM
C
      IF( IJ) 19,18,19
   18 SGR=2.*( SGR+ LOG(( SQRT( B* B+ S* S)+ S)/ B))
      SGI=2.* SGI
   19 CONTINUE
C
      RETURN
   20 FORMAT(' STEP SIZE LIMITED AT Z=',F10.5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      FUNCTION ISEGNO( ITAGI, MX)
C ***
C
C     ISEGNO RETURNS THE SEGMENT NUMBER OF THE MTH SEGMENT HAVING THE
C     TAG NUMBER ITAGI.  IF ITAGI=0 SEGMENT NUMBER M IS RETURNED.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      IF( MX.GT.0) GOTO 1
      WRITE( 6,6)
      STOP
    1 ICNT=0
      IF( ITAGI.NE.0) GOTO 2
      ISEGNO= MX
      RETURN
    2 IF( N.LT.1) GOTO 4
      DO 3  I=1, N
      IF( ITAG( I).NE. ITAGI) GOTO 3
      ICNT= ICNT+1
      IF( ICNT.EQ. MX) GOTO 5
    3 CONTINUE
    4 WRITE( 6,7)  ITAGI
      STOP
    5 ISEGNO= I
C
      RETURN
    6 FORMAT(4X,'CHECK DATA, PARAMETER SPECIFYING SEGMENT POSITION IN',
     &' A GROUP OF EQUAL TAGS MUST NOT BE ZERO')
    7 FORMAT(///,10X,'NO SEGMENT HAS AN ITAG OF ',I5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE LFACTR( A, NROW, IX1, IX2, IP)
C ***
C
C     LFACTR PERFORMS GAUSS-DOOLITTLE MANIPULATIONS ON THE TWO BLOCKS OF
C     THE TRANSPOSED MATRIX IN CORE STORAGE.  THE GAUSS-DOOLITTLE
C     ALGORITHM IS PRESENTED ON PAGES 411-416 OF A. RALSTON -- A FIRST
C     COURSE IN NUMERICAL ANALYSIS.  COMMENTS BELOW REFER TO COMMENTS IN
C     RALSTONS TEXT.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  A, D, AJR
      INTEGER  R, R1, R2, PJ, PR
      LOGICAL  L1, L2, L3
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      COMMON  /SCRATM/ D( N2M)
      DIMENSION  A( NROW,1), IP( NROW)
C
C     INITIALIZE R1,R2,J1,J2
C
      IFLG=0
      L1= IX1.EQ.1.AND. IX2.EQ.2
      L2=( IX2-1).EQ. IX1
      L3= IX2.EQ. NBLSYM
      IF( L1) GOTO 1
      GOTO 2
    1 R1=1
      R2=2* NPSYM
      J1=1
      J2=-1
      GOTO 5
    2 R1= NPSYM+1
      R2=2* NPSYM
      J1=( IX1-1)* NPSYM+1
      IF( L2) GOTO 3
      GOTO 4
    3 J2= J1+ NPSYM-2
      GOTO 5
    4 J2= J1+ NPSYM-1
    5 IF( L3) R2= NPSYM+ NLSYM
C
C     STEP 1
C
      DO 16  R= R1, R2
      DO 6  K= J1, NROW
      D( K)= A( K, R)
C
C     STEPS 2 AND 3
C
    6 CONTINUE
      IF( L1.OR. L2) J2= J2+1
      IF( J1.GT. J2) GOTO 9
      IXJ=0
      DO 8  J= J1, J2
      IXJ= IXJ+1
      PJ= IP( J)
      AJR= D( PJ)
      A( J, R)= AJR
      D( PJ)= D( J)
      JP1= J+1
      DO 7  I= JP1, NROW
      D( I)= D( I)- A( I, IXJ)* AJR
    7 CONTINUE
    8 CONTINUE
C
C     STEP 4
C
    9 CONTINUE
      J2P1= J2+1
      IF( L1.OR. L2) GOTO 11
      IF( NROW.LT. J2P1) GOTO 16
      DO 10  I= J2P1, NROW
      A( I, R)= D( I)
   10 CONTINUE
      GOTO 16
   11 DMAX= REAL( D( J2P1)* CONJG( D( J2P1)))
      IP( J2P1)= J2P1
      J2P2= J2+2
      IF( J2P2.GT. NROW) GOTO 13
      DO 12  I= J2P2, NROW
      ELMAG= REAL( D( I)* CONJG( D( I)))
      IF( ELMAG.LT. DMAX) GOTO 12
      DMAX= ELMAG
      IP( J2P1)= I
   12 CONTINUE
   13 CONTINUE
      IF( DMAX.LT.1.D-10) IFLG=1
      PR= IP( J2P1)
      A( J2P1, R)= D( PR)
C
C     STEP 5
C
      D( PR)= D( J2P1)
      IF( J2P2.GT. NROW) GOTO 15
      AJR=1./ A( J2P1, R)
      DO 14  I= J2P2, NROW
      A( I, R)= D( I)* AJR
   14 CONTINUE
   15 CONTINUE
      IF( IFLG.EQ.0) GOTO 16
      WRITE( 6,17)  J2, DMAX
      IFLG=0
   16 CONTINUE
C
      RETURN
   17 FORMAT(' ','PIVOT(,I3,2H)=',1P,E16.8)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE LOAD( LDTYP, LDTAG, LDTAGF, LDTAGT, ZLR, ZLI, ZLC)
C ***
C
C     LOAD CALCULATES THE IMPEDANCE OF SPECIFIED SEGMENTS FOR VARIOUS
C     TYPES OF LOADING
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  ZARRAY, ZT, TPCJ, ZINT
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
      DIMENSION  LDTYP(1), LDTAG(1), LDTAGF(1), LDTAGT(1), ZLR(1), ZLI(
     &1), ZLC(1), TPCJX(2)
      EQUIVALENCE(TPCJ,TPCJX)
C
C     WRITE(6,HEADING)
C
      DATA   TPCJX/0.,1.883698955D+9/
C
C     INITIALIZE D ARRAY, USED FOR TEMPORARY STORAGE OF LOADING
C     INFORMATION.
C
      WRITE( 6,25)
      DO 1  I= N2, N
    1 ZARRAY( I)=(0.,0.)
C
C     CYCLE OVER LOADING CARDS
C
      IWARN=0
      ISTEP=0
    2 ISTEP= ISTEP+1
      IF( ISTEP.LE. NLOAD) GOTO 5
      IF( IWARN.EQ.1) WRITE( 6,26)
      IF( N1+2* M1.GT.0) GOTO 4
      NOP= N/ NP
      IF( NOP.EQ.1) GOTO 4
      DO 3  I=1, NP
      ZT= ZARRAY( I)
      L1= I
      DO 3  L2=2, NOP
      L1= L1+ NP
    3 ZARRAY( L1)= ZT
    4 RETURN
    5 IF( LDTYP( ISTEP).LE.5) GOTO 6
      WRITE( 6,27)  LDTYP( ISTEP)
      STOP
    6 LDTAGS= LDTAG( ISTEP)
      JUMP= LDTYP( ISTEP)+1
C
C     SEARCH SEGMENTS FOR PROPER ITAGS
C
      ICHK=0
      L1= N2
      L2= N
      IF( LDTAGS.NE.0) GOTO 7
      IF( LDTAGF( ISTEP).EQ.0.AND. LDTAGT( ISTEP).EQ.0) GOTO 7
      L1= LDTAGF( ISTEP)
      L2= LDTAGT( ISTEP)
      IF( L1.GT. N1) GOTO 7
      WRITE( 6,29)
      STOP
    7 DO 17  I= L1, L2
      IF( LDTAGS.EQ.0) GOTO 8
      IF( LDTAGS.NE. ITAG( I)) GOTO 17
      IF( LDTAGF( ISTEP).EQ.0) GOTO 8
      ICHK= ICHK+1
      IF( ICHK.GE. LDTAGF( ISTEP).AND. ICHK.LE. LDTAGT( ISTEP)) GOTO 9
      GOTO 17
C
C     CALCULATION OF LAMDA*IMPED. PER UNIT LENGTH, JUMP TO APPROPRIATE
C     SECTION FOR LOADING TYPE
C
    8 ICHK=1
    9 GOTO (10,11,12,13,14,15), JUMP
   10 ZT= ZLR( ISTEP)/ SI( I)+ TPCJ* ZLI( ISTEP)/( SI( I)* WLAM)
      IF( ABS( ZLC( ISTEP)).GT.1.D-20) ZT= ZT+ WLAM/( TPCJ* SI( I)* ZLC
     &( ISTEP))
      GOTO 16
   11 ZT= TPCJ* SI( I)* ZLC( ISTEP)/ WLAM
      IF( ABS( ZLI( ISTEP)).GT.1.D-20) ZT= ZT+ SI( I)* WLAM/( TPCJ* ZLI
     &( ISTEP))
      IF( ABS( ZLR( ISTEP)).GT.1.D-20) ZT= ZT+ SI( I)/ ZLR( ISTEP)
      ZT=1./ ZT
      GOTO 16
   12 ZT= ZLR( ISTEP)* WLAM+ TPCJ* ZLI( ISTEP)
      IF( ABS( ZLC( ISTEP)).GT.1.D-20) ZT= ZT+1./( TPCJ* SI( I)* SI( I)
     &* ZLC( ISTEP))
      GOTO 16
   13 ZT= TPCJ* SI( I)* SI( I)* ZLC( ISTEP)
      IF( ABS( ZLI( ISTEP)).GT.1.D-20) ZT= ZT+1./( TPCJ* ZLI( ISTEP))
      IF( ABS( ZLR( ISTEP)).GT.1.D-20) ZT= ZT+1./( ZLR( ISTEP)* WLAM)
      ZT=1./ ZT
      GOTO 16
   14 ZT= CMPLX( ZLR( ISTEP), ZLI( ISTEP))/ SI( I)
      GOTO 16
   15 ZT= ZINT( ZLR( ISTEP)* WLAM, BI( I))
   16 IF(( ABS( REAL( ZARRAY( I)))+ ABS( AIMAG( ZARRAY( I)))).GT.1.D-20
     &) IWARN=1
      ZARRAY( I)= ZARRAY( I)+ ZT
   17 CONTINUE
      IF( ICHK.NE.0) GOTO 18
      WRITE( 6,28)  LDTAGS
C
C     PRINTING THE SEGMENT LOADING DATA, JUMP TO PROPER PRINT
C
      STOP
   18 GOTO (19,20,21,22,23,24), JUMP
   19 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP), ZLR( ISTEP),
     &ZLI( ISTEP), ZLC( ISTEP),0.,0.,0.,8H SERIES ,2)
      GOTO 2
   20 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP), ZLR( ISTEP),
     &ZLI( ISTEP), ZLC( ISTEP),0.,0.,0.,8HPARALLEL,2)
      GOTO 2
   21 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP), ZLR( ISTEP),
     &ZLI( ISTEP), ZLC( ISTEP),0.,0.,0.,18HSERIES (PER METER),5)
      GOTO 2
   22 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP), ZLR( ISTEP),
     &ZLI( ISTEP), ZLC( ISTEP),0.,0.,0.,20HPARALLEL (PER METER),5)
      GOTO 2
   23 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP),0.,0.,0., ZLR(
     &ISTEP), ZLI( ISTEP),0.,16HFIXED IMPEDANCE ,4)
      GOTO 2
   24 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP),0.,0.,0.,0.,0.,
     & ZLR( ISTEP),8H  WIRE  ,2)
C
      GOTO 2
   25 FORMAT(//,7X,'LOCATION',10X,'RESISTANCE',3X,'INDUCTANCE',2X,
     &'CAPACITANCE',7X,'IMPEDANCE (OHMS)',5X,'CONDUCTIVITY',4X,'TYPE',/
     &,4X,'ITAG',' FROM THRU',10X,'OHMS',8X,'HENRYS',7X,'FARADS',8X,
     &'REAL',6X,'IMAGINARY',4X,'MHOS/METER')
   26 FORMAT(/,10X,'NOTE, SOME OF THE ABOVE SEGMENTS HAVE BEEN LOADED',
     &' TWICE - IMPEDANCES ADDED')
   27 FORMAT(/,10X,'IMPROPER LOAD TYPE CHOOSEN, REQUESTED TYPE IS ',I3)
     &
   28 FORMAT(/,10X,'LOADING DATA CARD ERROR, NO SEGMENT HAS AN ITAG =',
     &I5)
   29 FORMAT(' ERROR - LOADING MAY NOT BE ADDED TO SEGMENTS IN N.G.F.'
     &' SECTION')
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE LTSOLV( A, NROW, IX, B, NEQ, NRH, IFL1, IFL2)
C ***
C
C     LTSOLV SOLVES THE MATRIX EQ. Y(R)*LU(T)=B(R) WHERE (R) DENOTES ROW
C     VECTOR AND LU(T) DENOTES THE LU DECOMPOSITION OF THE TRANSPOSE OF
C     THE ORIGINAL COEFFICIENT MATRIX.  THE LU(T) DECOMPOSITION IS
C     STORED ON TAPE 5 IN BLOCKS IN ASCENDING ORDER AND ON FILE 3 IN
C     BLOCKS OF DESCENDING ORDER.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  A, B, Y, SUM
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      COMMON  /SCRATM/ Y( N2M)
C
C     FORWARD SUBSTITUTION
C
      DIMENSION  A( NROW, NROW), B( NEQ, NRH), IX( NEQ)
      I2=2* NPSYM* NROW
      DO 4  IXBLK1=1, NBLSYM
      CALL BLCKIN( A, IFL1,1, I2,1,121)
      K2= NPSYM
      IF( IXBLK1.EQ. NBLSYM) K2= NLSYM
      JST=( IXBLK1-1)* NPSYM
      DO 4  IC=1, NRH
      J= JST
      DO 3  K=1, K2
      JM1= J
      J= J+1
      SUM=(0.,0.)
      IF( JM1.LT.1) GOTO 2
      DO 1  I=1, JM1
    1 SUM= SUM+ A( I, K)* B( I, IC)
    2 B( J, IC)=( B( J, IC)- SUM)/ A( J, K)
    3 CONTINUE
C
C     BACKWARD SUBSTITUTION
C
    4 CONTINUE
      JST= NROW+1
      DO 8  IXBLK1=1, NBLSYM
      CALL BLCKIN( A, IFL2,1, I2,1,122)
      K2= NPSYM
      IF( IXBLK1.EQ.1) K2= NLSYM
      DO 7  IC=1, NRH
      KP= K2+1
      J= JST
      DO 6  K=1, K2
      KP= KP-1
      JP1= J
      J= J-1
      SUM=(0.,0.)
      IF( NROW.LT. JP1) GOTO 6
      DO 5  I= JP1, NROW
    5 SUM= SUM+ A( I, KP)* B( I, IC)
      B( J, IC)= B( J, IC)- SUM
    6 CONTINUE
    7 CONTINUE
C
C     UNSCRAMBLE SOLUTION
C
    8 JST= JST- K2
      DO 10  IC=1, NRH
      DO 9  I=1, NROW
      IXI= IX( I)
    9 Y( IXI)= B( I, IC)
      DO 10  I=1, NROW
   10 B( I, IC)= Y( I)
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE LUNSCR( A, NROW, NOP, IX, IP, IU2, IU3, IU4)
C ***
C
C     S/R WHICH UNSCRAMBLES, SCRAMBLED FACTORED MATRIX
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  A, TEMP
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      DIMENSION  A( NROW,1), IP( NROW), IX( NROW)
      I1=1
      I2=2* NPSYM* NROW
      NM1= NROW-1
      REWIND IU2
      REWIND IU3
      REWIND IU4
      DO 9  KK=1, NOP
      KA=( KK-1)* NROW
      DO 4  IXBLK1=1, NBLSYM
      CALL BLCKIN( A, IU2, I1, I2,1,121)
      K1=( IXBLK1-1)* NPSYM+2
      IF( NM1.LT. K1) GOTO 3
      J2=0
      DO 2  K= K1, NM1
      IF( J2.LT. NPSYM) J2= J2+1
      IPK= IP( K+ KA)
      DO 1  J=1, J2
      TEMP= A( K, J)
      A( K, J)= A( IPK, J)
      A( IPK, J)= TEMP
    1 CONTINUE
    2 CONTINUE
    3 CONTINUE
      CALL BLCKOT( A, IU3, I1, I2,1,122)
    4 CONTINUE
      DO 5  IXBLK1=1, NBLSYM
      BACKSPACE IU3
      IF( IXBLK1.NE.1) BACKSPACE IU3
      CALL BLCKIN( A, IU3, I1, I2,1,123)
      CALL BLCKOT( A, IU4, I1, I2,1,124)
    5 CONTINUE
      DO 6  I=1, NROW
      IX( I+ KA)= I
    6 CONTINUE
      DO 7  I=1, NROW
      IPI= IP( I+ KA)
      IXT= IX( I+ KA)
      IX( I+ KA)= IX( IPI+ KA)
      IX( IPI+ KA)= IXT
    7 CONTINUE
      IF( NOP.EQ.1) GOTO 9
C     SKIP NB1 LOGICAL RECORDS FORWARD
      NB1= NBLSYM-1
      DO 8  IXBLK1=1, NB1
      CALL BLCKIN( A, IU3, I1, I2,1,125)
    8 CONTINUE
    9 CONTINUE
      REWIND IU2
      REWIND IU3
      REWIND IU4
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE MOVE( ROX, ROY, ROZ, XS, YS, ZS, ITS, NRPT, ITGI)
C ***
C
C     SUBROUTINE MOVE MOVES THE STRUCTURE WITH RESPECT TO ITS
C     COORDINATE SYSTEM OR REPRODUCES STRUCTURE IN NEW POSITIONS.
C     STRUCTURE IS ROTATED ABOUT X,Y,Z AXES BY ROX,ROY,ROZ
C     RESPECTIVELY, THEN SHIFTED BY XS,YS,ZS
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ANGL/ SALP( NM)
      DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), X2(1),
     & Y2(1), Z2(1)
      EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1))
      EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
     &T2Z,ITAG)
      IF( ABS( ROX)+ ABS( ROY).GT.1.D-10) IPSYM= IPSYM*3
      SPS= SIN( ROX)
      CPS= COS( ROX)
      STH= SIN( ROY)
      CTH= COS( ROY)
      SPH= SIN( ROZ)
      CPH= COS( ROZ)
      XX= CPH* CTH
      XY= CPH* STH* SPS- SPH* CPS
      XZ= CPH* STH* CPS+ SPH* SPS
      YX= SPH* CTH
      YY= SPH* STH* SPS+ CPH* CPS
      YZ= SPH* STH* CPS- CPH* SPS
      ZX=- STH
      ZY= CTH* SPS
      ZZ= CTH* CPS
      NRP= NRPT
      IF( NRPT.EQ.0) NRP=1
      IX=1
      IF( N.LT. N2) GOTO 3
      I1= ISEGNO( ITS,1)
      IF( I1.LT. N2) I1= N2
      IX= I1
      K= N
      IF( NRPT.EQ.0) K= I1-1
      DO 2  IR=1, NRP
      DO 1  I= I1, N
      K= K+1
      XI= X( I)
      YI= Y( I)
      ZI= Z( I)
      X( K)= XI* XX+ YI* XY+ ZI* XZ+ XS
      Y( K)= XI* YX+ YI* YY+ ZI* YZ+ YS
      Z( K)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS
      XI= X2( I)
      YI= Y2( I)
      ZI= Z2( I)
      X2( K)= XI* XX+ YI* XY+ ZI* XZ+ XS
      Y2( K)= XI* YX+ YI* YY+ ZI* YZ+ YS
      Z2( K)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS
      BI( K)= BI( I)
      ITAG( K)= ITAG( I)
      IF( ITAG( I).NE.0) ITAG( K)= ITAG( I)+ ITGI
    1 CONTINUE
      I1= N+1
      N= K
    2 CONTINUE
    3 IF( M.LT. M2) GOTO 6
      I1= M2
      K= M
      LDI= LD+1
      IF( NRPT.EQ.0) K= M1
      DO 5  II=1, NRP
      DO 4  I= I1, M
      K= K+1
      IR= LDI- I
      KR= LDI- K
      XI= X( IR)
      YI= Y( IR)
      ZI= Z( IR)
      X( KR)= XI* XX+ YI* XY+ ZI* XZ+ XS
      Y( KR)= XI* YX+ YI* YY+ ZI* YZ+ YS
      Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS
      XI= T1X( IR)
      YI= T1Y( IR)
      ZI= T1Z( IR)
      T1X( KR)= XI* XX+ YI* XY+ ZI* XZ
      T1Y( KR)= XI* YX+ YI* YY+ ZI* YZ
      T1Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ
      XI= T2X( IR)
      YI= T2Y( IR)
      ZI= T2Z( IR)
      T2X( KR)= XI* XX+ YI* XY+ ZI* XZ
      T2Y( KR)= XI* YX+ YI* YY+ ZI* YZ
      T2Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ
      SALP( KR)= SALP( IR)
    4 BI( KR)= BI( IR)
      I1= M+1
    5 M= K
    6 IF(( NRPT.EQ.0).AND.( IX.EQ.1)) RETURN
      NP= N
      MP= M
      IPSYM=0
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE NEFLD( XOB, YOB, ZOB, EX, EY, EZ)
C ***
C
C     NEFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER
C     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  EX, EY, EZ, CUR, ACX, BCX, CCX, EXK, EYK, EZK, EXS,
     &EYS, EZS, EXC, EYC, EZC, ZRATI, ZRATI2, T1, FRATI
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ANGL/ SALP( NM)
      COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
     &CII( NM), CUR( N3M)
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
     &KSYMP, IFAR, IPERF, T1, T2
      DIMENSION  CAB(1), SAB(1), T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1)
     &, T2Z(1)
      EQUIVALENCE(CAB,ALP),(SAB,BET)
      EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
     &T2Z,ITAG)
      EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
     &IND1),(T2ZJ,IND2)
      EX=(0.,0.)
      EY=(0.,0.)
      EZ=(0.,0.)
      AX=0.
      IF( N.EQ.0) GOTO 20
      DO 1  I=1, N
      XJ= XOB- X( I)
      YJ= YOB- Y( I)
      ZJ= ZOB- Z( I)
      ZP= CAB( I)* XJ+ SAB( I)* YJ+ SALP( I)* ZJ
      IF( ABS( ZP).GT.0.5001* SI( I)) GOTO 1
      ZP= XJ* XJ+ YJ* YJ+ ZJ* ZJ- ZP* ZP
      XJ= BI( I)
      IF( ZP.GT.0.9* XJ* XJ) GOTO 1
      AX= XJ
      GOTO 2
    1 CONTINUE
    2 DO 19  I=1, N
      S= SI( I)
      B= BI( I)
      XJ= X( I)
      YJ= Y( I)
      ZJ= Z( I)
      CABJ= CAB( I)
      SABJ= SAB( I)
      SALPJ= SALP( I)
      IF( IEXK.EQ.0) GOTO 18
      IPR= ICON1( I)
      IF( IPR) 3,8,4
    3 IPR=- IPR
      IF(- ICON1( IPR).NE. I) GOTO 9
      GOTO 6
    4 IF( IPR.NE. I) GOTO 5
      IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 9
      GOTO 7
    5 IF( ICON2( IPR).NE. I) GOTO 9
    6 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
      IF( XI.LT.0.999999D+0) GOTO 9
      IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 9
    7 IND1=0
      GOTO 10
    8 IND1=1
      GOTO 10
    9 IND1=2
   10 IPR= ICON2( I)
      IF( IPR) 11,16,12
   11 IPR=- IPR
      IF(- ICON2( IPR).NE. I) GOTO 17
      GOTO 14
   12 IF( IPR.NE. I) GOTO 13
      IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 17
      GOTO 15
   13 IF( ICON1( IPR).NE. I) GOTO 17
   14 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
      IF( XI.LT.0.999999D+0) GOTO 17
      IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 17
   15 IND2=0
      GOTO 18
   16 IND2=1
      GOTO 18
   17 IND2=2
   18 CONTINUE
      CALL EFLD( XOB, YOB, ZOB, AX,1)
      ACX= CMPLX( AIR( I), AII( I))
      BCX= CMPLX( BIR( I), BII( I))
      CCX= CMPLX( CIR( I), CII( I))
      EX= EX+ EXK* ACX+ EXS* BCX+ EXC* CCX
      EY= EY+ EYK* ACX+ EYS* BCX+ EYC* CCX
   19 EZ= EZ+ EZK* ACX+ EZS* BCX+ EZC* CCX
      IF( M.EQ.0) RETURN
   20 JC= N
      JL= LD+1
      DO 21  I=1, M
      JL= JL-1
      S= BI( JL)
      XJ= X( JL)
      YJ= Y( JL)
      ZJ= Z( JL)
      T1XJ= T1X( JL)
      T1YJ= T1Y( JL)
      T1ZJ= T1Z( JL)
      T2XJ= T2X( JL)
      T2YJ= T2Y( JL)
      T2ZJ= T2Z( JL)
      JC= JC+3
      ACX= T1XJ* CUR( JC-2)+ T1YJ* CUR( JC-1)+ T1ZJ* CUR( JC)
      BCX= T2XJ* CUR( JC-2)+ T2YJ* CUR( JC-1)+ T2ZJ* CUR( JC)
      DO 21  IP=1, KSYMP
      IPGND= IP
      CALL UNERE( XOB, YOB, ZOB)
      EX= EX+ ACX* EXK+ BCX* EXS
      EY= EY+ ACX* EYK+ BCX* EYS
   21 EZ= EZ+ ACX* EZK+ BCX* EZS
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE NETWK( CM, CMB, CMC, CMD, IP, EINC)
C ***
C
C     SUBROUTINE NETWK SOLVES FOR STRUCTURE CURRENTS FOR A GIVEN
C     EXCITATION INCLUDING THE EFFECT OF NON-RADIATING NETWORKS IF
C     PRESENT.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  CMN, RHNT, YMIT, RHS, ZPED, EINC, VSANT, VLT, CUR,
     &VSRC, RHNX, VQD, VQDS, CUX, CM, CMB, CMC, CMD
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
     &CII( NM), CUR( N3M)
      COMMON  /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
     &, IQDS(30), NVQD, NSANT, NQDS
      COMMON  /NETCX/ ZPED, PIN, PNLS, NEQ, NPEQ, NEQ2, NONET, NTSOL,
     &NPRINT, MASYM, ISEG1(150), ISEG2(150), X11R(150), X11I(150),
     &X12R(150), X12I(150), X22R(150), X22I(150), NTYP(150)
      DIMENSION  EINC(1), IP(1), CM(1), CMB(1), CMC(1), CMD(1)
      DIMENSION  CMN(150,150), RHNT(150), IPNT(150), NTEQA(150),
     &NTSCA(150), RHS( N3M), VSRC(10), RHNX(150)
      DATA   NDIMN, NDIMNP/150,151/, TP/6.283185308D+0/
      NEQZ2= NEQ2
      IF( NEQZ2.EQ.0) NEQZ2=1
      PIN=0.
      PNLS=0.
      NEQT= NEQ+ NEQ2
      IF( NTSOL.NE.0) GOTO 42
      NOP= NEQ/ NPEQ
C
C     COMPUTE RELATIVE MATRIX ASYMMETRY
C
      IF( MASYM.EQ.0) GOTO 14
      IROW1=0
      IF( NONET.EQ.0) GOTO 5
      DO 4  I=1, NONET
      NSEG1= ISEG1( I)
      DO 3  ISC1=1,2
      IF( IROW1.EQ.0) GOTO 2
      DO 1  J=1, IROW1
      IF( NSEG1.EQ. IPNT( J)) GOTO 3
    1 CONTINUE
    2 IROW1= IROW1+1
      IPNT( IROW1)= NSEG1
    3 NSEG1= ISEG2( I)
    4 CONTINUE
    5 IF( NSANT.EQ.0) GOTO 9
      DO 8  I=1, NSANT
      NSEG1= ISANT( I)
      IF( IROW1.EQ.0) GOTO 7
      DO 6  J=1, IROW1
      IF( NSEG1.EQ. IPNT( J)) GOTO 8
    6 CONTINUE
    7 IROW1= IROW1+1
      IPNT( IROW1)= NSEG1
    8 CONTINUE
    9 IF( IROW1.LT. NDIMNP) GOTO 10
      WRITE( 6,59)
      STOP
   10 IF( IROW1.LT.2) GOTO 14
      DO 12  I=1, IROW1
      ISC1= IPNT( I)
      ASM= SI( ISC1)
      DO 11  J=1, NEQT
   11 RHS( J)=(0.,0.)
      RHS( ISC1)=(1.,0.)
      CALL SOLGF( CM, CMB, CMC, CMD, RHS, IP, NP, N1, N, MP, M1, M, NEQ
     &, NEQ2, NEQZ2)
      CALL CABC( RHS)
      DO 12  J=1, IROW1
      ISC1= IPNT( J)
   12 CMN( J, I)= RHS( ISC1)/ ASM
      ASM=0.
      ASA=0.
      DO 13  I=2, IROW1
      ISC1= I-1
      DO 13  J=1, ISC1
      CUX= CMN( I, J)
      PWR= ABS(( CUX- CMN( J, I))/ CUX)
      ASA= ASA+ PWR* PWR
      IF( PWR.LT. ASM) GOTO 13
      ASM= PWR
      NTEQ= IPNT( I)
      NTSC= IPNT( J)
   13 CONTINUE
      ASA= SQRT( ASA*2./ DFLOAT( IROW1*( IROW1-1)))
      WRITE( 6,58)  ASM, NTEQ, NTSC, ASA
C
C     SOLUTION OF NETWORK EQUATIONS
C
   14 IF( NONET.EQ.0) GOTO 48
      DO 15  I=1, NDIMN
      RHNX( I)=(0.,0.)
      DO 15  J=1, NDIMN
   15 CMN( I, J)=(0.,0.)
      NTEQ=0
C
C     SORT NETWORK AND SOURCE DATA AND ASSIGN EQUATION NUMBERS TO
C     SEGMENTS.
C
      NTSC=0
      DO 38  J=1, NONET
      NSEG1= ISEG1( J)
      NSEG2= ISEG2( J)
      IF( NTYP( J).GT.1) GOTO 16
      Y11R= X11R( J)
      Y11I= X11I( J)
      Y12R= X12R( J)
      Y12I= X12I( J)
      Y22R= X22R( J)
      Y22I= X22I( J)
      GOTO 17
   16 Y22R= TP* X11I( J)/ WLAM
      Y12R=0.
      Y12I=1./( X11R( J)* SIN( Y22R))
      Y11R= X12R( J)
      Y11I=- Y12I* COS( Y22R)
      Y22R= X22R( J)
      Y22I= Y11I+ X22I( J)
      Y11I= Y11I+ X12I( J)
      IF( NTYP( J).EQ.2) GOTO 17
      Y12R=- Y12R
      Y12I=- Y12I
   17 IF( NSANT.EQ.0) GOTO 19
      DO 18  I=1, NSANT
      IF( NSEG1.NE. ISANT( I)) GOTO 18
      ISC1= I
      GOTO 22
   18 CONTINUE
   19 ISC1=0
      IF( NTEQ.EQ.0) GOTO 21
      DO 20  I=1, NTEQ
      IF( NSEG1.NE. NTEQA( I)) GOTO 20
      IROW1= I
      GOTO 25
   20 CONTINUE
   21 NTEQ= NTEQ+1
      IROW1= NTEQ
      NTEQA( NTEQ)= NSEG1
      GOTO 25
   22 IF( NTSC.EQ.0) GOTO 24
      DO 23  I=1, NTSC
      IF( NSEG1.NE. NTSCA( I)) GOTO 23
      IROW1= NDIMNP- I
      GOTO 25
   23 CONTINUE
   24 NTSC= NTSC+1
      IROW1= NDIMNP- NTSC
      NTSCA( NTSC)= NSEG1
      VSRC( NTSC)= VSANT( ISC1)
   25 IF( NSANT.EQ.0) GOTO 27
      DO 26  I=1, NSANT
      IF( NSEG2.NE. ISANT( I)) GOTO 26
      ISC2= I
      GOTO 30
   26 CONTINUE
   27 ISC2=0
      IF( NTEQ.EQ.0) GOTO 29
      DO 28  I=1, NTEQ
      IF( NSEG2.NE. NTEQA( I)) GOTO 28
      IROW2= I
      GOTO 33
   28 CONTINUE
   29 NTEQ= NTEQ+1
      IROW2= NTEQ
      NTEQA( NTEQ)= NSEG2
      GOTO 33
   30 IF( NTSC.EQ.0) GOTO 32
      DO 31  I=1, NTSC
      IF( NSEG2.NE. NTSCA( I)) GOTO 31
      IROW2= NDIMNP- I
      GOTO 33
   31 CONTINUE
   32 NTSC= NTSC+1
      IROW2= NDIMNP- NTSC
      NTSCA( NTSC)= NSEG2
      VSRC( NTSC)= VSANT( ISC2)
   33 IF( NTSC+ NTEQ.LT. NDIMNP) GOTO 34
      WRITE( 6,59)
C
C     FILL NETWORK EQUATION MATRIX AND RIGHT HAND SIDE VECTOR WITH
C     NETWORK SHORT-CIRCUIT ADMITTANCE MATRIX COEFFICIENTS.
C
      STOP
   34 IF( ISC1.NE.0) GOTO 35
      CMN( IROW1, IROW1)= CMN( IROW1, IROW1)- CMPLX( Y11R, Y11I)* SI(
     &NSEG1)
      CMN( IROW1, IROW2)= CMN( IROW1, IROW2)- CMPLX( Y12R, Y12I)* SI(
     &NSEG1)
      GOTO 36
   35 RHNX( IROW1)= RHNX( IROW1)+ CMPLX( Y11R, Y11I)* VSANT( ISC1)/
     &WLAM
      RHNX( IROW2)= RHNX( IROW2)+ CMPLX( Y12R, Y12I)* VSANT( ISC1)/
     &WLAM
   36 IF( ISC2.NE.0) GOTO 37
      CMN( IROW2, IROW2)= CMN( IROW2, IROW2)- CMPLX( Y22R, Y22I)* SI(
     &NSEG2)
      CMN( IROW2, IROW1)= CMN( IROW2, IROW1)- CMPLX( Y12R, Y12I)* SI(
     &NSEG2)
      GOTO 38
   37 RHNX( IROW1)= RHNX( IROW1)+ CMPLX( Y12R, Y12I)* VSANT( ISC2)/
     &WLAM
      RHNX( IROW2)= RHNX( IROW2)+ CMPLX( Y22R, Y22I)* VSANT( ISC2)/
     &WLAM
C
C     ADD INTERACTION MATRIX ADMITTANCE ELEMENTS TO NETWORK EQUATION
C     MATRIX
C
   38 CONTINUE
      DO 41  I=1, NTEQ
      DO 39  J=1, NEQT
   39 RHS( J)=(0.,0.)
      IROW1= NTEQA( I)
      RHS( IROW1)=(1.,0.)
      CALL SOLGF( CM, CMB, CMC, CMD, RHS, IP, NP, N1, N, MP, M1, M, NEQ
     &, NEQ2, NEQZ2)
      CALL CABC( RHS)
      DO 40  J=1, NTEQ
      IROW1= NTEQA( J)
   40 CMN( I, J)= CMN( I, J)+ RHS( IROW1)
C
C     FACTOR NETWORK EQUATION MATRIX
C
   41 CONTINUE
C
C     ADD TO NETWORK EQUATION RIGHT HAND SIDE THE TERMS DUE TO ELEMENT
C     INTERACTIONS
C
      CALL FACTR( NTEQ, CMN, IPNT, NDIMN)
   42 IF( NONET.EQ.0) GOTO 48
      DO 43  I=1, NEQT
   43 RHS( I)= EINC( I)
      CALL SOLGF( CM, CMB, CMC, CMD, RHS, IP, NP, N1, N, MP, M1, M, NEQ
     &, NEQ2, NEQZ2)
      CALL CABC( RHS)
      DO 44  I=1, NTEQ
      IROW1= NTEQA( I)
C
C     SOLVE NETWORK EQUATIONS
C
   44 RHNT( I)= RHNX( I)+ RHS( IROW1)
C
C     ADD FIELDS DUE TO NETWORK VOLTAGES TO ELECTRIC FIELDS APPLIED TO
C     STRUCTURE AND SOLVE FOR INDUCED CURRENT
C
      CALL SOLVE( NTEQ, CMN, IPNT, RHNT, NDIMN)
      DO 45  I=1, NTEQ
      IROW1= NTEQA( I)
   45 EINC( IROW1)= EINC( IROW1)- RHNT( I)
      CALL SOLGF( CM, CMB, CMC, CMD, EINC, IP, NP, N1, N, MP, M1, M,
     &NEQ, NEQ2, NEQZ2)
      CALL CABC( EINC)
      IF( NPRINT.EQ.0) WRITE( 6,61)
      IF( NPRINT.EQ.0) WRITE( 6,60)
      DO 46  I=1, NTEQ
      IROW1= NTEQA( I)
      VLT= RHNT( I)* SI( IROW1)* WLAM
      CUX= EINC( IROW1)* WLAM
      YMIT= CUX/ VLT
      ZPED= VLT/ CUX
      IROW2= ITAG( IROW1)
      PWR=.5* REAL( VLT* CONJG( CUX))
      PNLS= PNLS- PWR
   46 IF( NPRINT.EQ.0) WRITE( 6,62)  IROW2, IROW1, VLT, CUX, ZPED, YMIT
     &, PWR
      IF( NTSC.EQ.0) GOTO 49
      DO 47  I=1, NTSC
      IROW1= NTSCA( I)
      VLT= VSRC( I)
      CUX= EINC( IROW1)* WLAM
      YMIT= CUX/ VLT
      ZPED= VLT/ CUX
      IROW2= ITAG( IROW1)
      PWR=.5* REAL( VLT* CONJG( CUX))
      PNLS= PNLS- PWR
   47 IF( NPRINT.EQ.0) WRITE( 6,62)  IROW2, IROW1, VLT, CUX, ZPED, YMIT
     &, PWR
C
C     SOLVE FOR CURRENTS WHEN NO NETWORKS ARE PRESENT
C
      GOTO 49
   48 CALL SOLGF( CM, CMB, CMC, CMD, EINC, IP, NP, N1, N, MP, M1, M,
     &NEQ, NEQ2, NEQZ2)
      CALL CABC( EINC)
      NTSC=0
   49 IF( NSANT+ NVQD.EQ.0) RETURN
      WRITE( 6,63)
      WRITE( 6,60)
      IF( NSANT.EQ.0) GOTO 56
      DO 55  I=1, NSANT
      ISC1= ISANT( I)
      VLT= VSANT( I)
      IF( NTSC.EQ.0) GOTO 51
      DO 50  J=1, NTSC
      IF( NTSCA( J).EQ. ISC1) GOTO 52
   50 CONTINUE
   51 CUX= EINC( ISC1)* WLAM
      IROW1=0
      GOTO 54
   52 IROW1= NDIMNP- J
      CUX= RHNX( IROW1)
      DO 53  J=1, NTEQ
   53 CUX= CUX- CMN( J, IROW1)* RHNT( J)
      CUX=( EINC( ISC1)+ CUX)* WLAM
   54 YMIT= CUX/ VLT
      ZPED= VLT/ CUX
      PWR=.5* REAL( VLT* CONJG( CUX))
      PIN= PIN+ PWR
      IF( IROW1.NE.0) PNLS= PNLS+ PWR
      IROW2= ITAG( ISC1)
   55 WRITE( 6,62)  IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR
   56 IF( NVQD.EQ.0) RETURN
      DO 57  I=1, NVQD
      ISC1= IVQD( I)
      VLT= VQD( I)
      CUX= CMPLX( AIR( ISC1), AII( ISC1))
      YMIT= CMPLX( BIR( ISC1), BII( ISC1))
      ZPED= CMPLX( CIR( ISC1), CII( ISC1))
      PWR= SI( ISC1)* TP*.5
      CUX=( CUX- YMIT* SIN( PWR)+ ZPED* COS( PWR))* WLAM
      YMIT= CUX/ VLT
      ZPED= VLT/ CUX
      PWR=.5* REAL( VLT* CONJG( CUX))
      PIN= PIN+ PWR
      IROW2= ITAG( ISC1)
   57 WRITE( 6,64)  IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR
C
      RETURN
   58 FORMAT(///,3X,'MAXIMUM RELATIVE ASYMMETRY OF THE DRIVING POINT',
     &' ADMITTANCE MATRIX IS',1P,E10.3,' FOR SEGMENTS',I5,4H AND,I5,/,3
     &X,'RMS RELATIVE ASYMMETRY IS',E10.3)
   59 FORMAT(1X,'ERROR - - NETWORK ARRAY DIMENSIONS TOO SMALL')
   60 FORMAT(/,3X,'TAG',3X,'SEG.',4X,'VOLTAGE (VOLTS)',9X,'CURRENT (',
     &'AMPS)',9X,'IMPEDANCE (OHMS)',8X,'ADMITTANCE (MHOS)',6X,'POWER',/
     &,3X,'NO.',3X,'NO.',4X,'REAL',8X,'IMAG.',3(7X,'REAL',8X,'IMAG.'),5
     &X,'(WATTS)')
   61 FORMAT(///,27X,'- - - STRUCTURE EXCITATION DATA AT NETWORK CONN',
     &'ECTION POINTS - - -')
   62 FORMAT(2(1X,I5),1P,9E12.5)
   63 FORMAT(///,42X,'- - - ANTENNA INPUT PARAMETERS - - -')
   64 FORMAT(1X,I5,' *',I4,1P,9E12.5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE NFPAT
C ***
C     COMPUTE NEAR E OR H FIELDS OVER A RANGE OF POINTS
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  EX, EY, EZ
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
C***
      COMMON  /FPAT/ NTH, NPH, IPD, IAVP, INOR, IAX, THETS, PHIS, DTH,
     &DPH, RFLD, GNOR, CLT, CHT, EPSR2, SIG2, IXTYP, XPR6, PINR, PNLR,
     &PLOSS, NEAR, NFEH, NRX, NRY, NRZ, XNR, YNR, ZNR, DXNR, DYNR, DZNR
     &
C***
      COMMON  /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4
      DATA   TA/1.745329252D-02/
      IF( NFEH.EQ.1) GOTO 1
      WRITE( 6,10)
      GOTO 2
    1 WRITE( 6,12)
    2 ZNRT= ZNR- DZNR
      DO 9  I=1, NRZ
      ZNRT= ZNRT+ DZNR
      IF( NEAR.EQ.0) GOTO 3
      CTH= COS( TA* ZNRT)
      STH= SIN( TA* ZNRT)
    3 YNRT= YNR- DYNR
      DO 9  J=1, NRY
      YNRT= YNRT+ DYNR
      IF( NEAR.EQ.0) GOTO 4
      CPH= COS( TA* YNRT)
      SPH= SIN( TA* YNRT)
    4 XNRT= XNR- DXNR
      DO 9  KK=1, NRX
      XNRT= XNRT+ DXNR
      IF( NEAR.EQ.0) GOTO 5
      XOB= XNRT* STH* CPH
      YOB= XNRT* STH* SPH
      ZOB= XNRT* CTH
      GOTO 6
    5 XOB= XNRT
      YOB= YNRT
      ZOB= ZNRT
    6 TMP1= XOB/ WLAM
      TMP2= YOB/ WLAM
      TMP3= ZOB/ WLAM
      IF( NFEH.EQ.1) GOTO 7
      CALL NEFLD( TMP1, TMP2, TMP3, EX, EY, EZ)
      GOTO 8
    7 CALL NHFLD( TMP1, TMP2, TMP3, EX, EY, EZ)
    8 TMP1= ABS( EX)
      TMP2= CANG( EX)
      TMP3= ABS( EY)
      TMP4= CANG( EY)
      TMP5= ABS( EZ)
      TMP6= CANG( EZ)
C***
      WRITE( 6,11)  XOB, YOB, ZOB, TMP1, TMP2, TMP3, TMP4, TMP5, TMP6
      IF( IPLP1.NE.2) GOTO 9
      GOTO (14,15,16), IPLP4
   14 XXX= XOB
      GOTO 17
   15 XXX= YOB
      GOTO 17
   16 XXX= ZOB
   17 CONTINUE
      IF( IPLP2.NE.2) GOTO 13
      IF( IPLP3.EQ.1) WRITE( 8,*)  XXX, TMP1, TMP2
      IF( IPLP3.EQ.2) WRITE( 8,*)  XXX, TMP3, TMP4
      IF( IPLP3.EQ.3) WRITE( 8,*)  XXX, TMP5, TMP6
      IF( IPLP3.EQ.4) WRITE( 8,*)  XXX, TMP1, TMP2, TMP3, TMP4, TMP5,
     &TMP6
      GOTO 9
   13 IF( IPLP2.NE.1) GOTO 9
      IF( IPLP3.EQ.1) WRITE( 8,*)  XXX, EX
      IF( IPLP3.EQ.2) WRITE( 8,*)  XXX, EY
      IF( IPLP3.EQ.3) WRITE( 8,*)  XXX, EZ
C***
      IF( IPLP3.EQ.4) WRITE( 8,*)  XXX, EX, EY, EZ
    9 CONTINUE
C
      RETURN
   10 FORMAT(///,35X,'- - - NEAR ELECTRIC FIELDS - - -',//,12X,'-  L',
     &'OCATION  -',21X,'-  EX  -',15X,'-  EY  -',15X,'-  EZ  -',/,8X,
     &'X',10X,'Y',10X,'Z',10X,'MAGNITUDE',3X,'PHASE',6X,'MAGNITUDE',3X,
     &'PHASE',6X,'MAGNITUDE',3X,'PHASE',/,6X,'METERS',5X,'METERS',5X,
     &'METERS',8X,'VOLTS/M',3X,'DEGREES',6X,'VOLTS/M',3X,'DEGREES',6X
     &,'VOLTS/M',3X,'DEGREES')
   11 FORMAT(2X,3(2X,F9.4),1X,3(3X,1P,E11.4,2X,0P,F7.2))
   12 FORMAT(///,35X,'- - - NEAR MAGNETIC FIELDS - - -',//,12X,'-  L',
     &'OCATION  -',21X,'-  HX  -',15X,'-  HY  -',15X,'-  HZ  -',/,8X,
     &'X',10X,'Y',10X,'Z',10X,'MAGNITUDE',3X,'PHASE',6X,'MAGNITUDE',3X,
     &'PHASE',6X,'MAGNITUDE',3X,'PHASE',/,6X,'METERS',5X,'METERS',5X,
     &'METERS',9X,'AMPS/M',3X,'DEGREES',7X,'AMPS/M',3X,'DEGREES',7X,
     &'AMPS/M',3X,'DEGREES')
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE NHFLD( XOB, YOB, ZOB, HX, HY, HZ)
C ***
C
C     NHFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER
C     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEXHX,HY,HZ,CUR,ACX,  BCX, CCX, EXK, EYK, EZK, EXS, EYS,
     &EZS, EXC, EYC, EZC
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ANGL/ SALP( NM)
      COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM),
     &CII( NM), CUR( N3M)
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      DIMENSION  CAB(1), SAB(1)
      DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), XS(1),
     & YS(1), ZS(1)
      EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
     &T2Z,ITAG),(XS,X),(YS,Y),(ZS,Z)
      EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
     &IND1),(T2ZJ,IND2)
      EQUIVALENCE(CAB,ALP),(SAB,BET)
      HX=(0.,0.)
      HY=(0.,0.)
      HZ=(0.,0.)
      AX=0.
      IF( N.EQ.0) GOTO 4
      DO 1  I=1, N
      XJ= XOB- X( I)
      YJ= YOB- Y( I)
      ZJ= ZOB- Z( I)
      ZP= CAB( I)* XJ+ SAB( I)* YJ+ SALP( I)* ZJ
      IF( ABS( ZP).GT.0.5001* SI( I)) GOTO 1
      ZP= XJ* XJ+ YJ* YJ+ ZJ* ZJ- ZP* ZP
      XJ= BI( I)
      IF( ZP.GT.0.9* XJ* XJ) GOTO 1
      AX= XJ
      GOTO 2
    1 CONTINUE
    2 DO 3  I=1, N
      S= SI( I)
      B= BI( I)
      XJ= X( I)
      YJ= Y( I)
      ZJ= Z( I)
      CABJ= CAB( I)
      SABJ= SAB( I)
      SALPJ= SALP( I)
      CALL HSFLD( XOB, YOB, ZOB, AX)
      ACX= CMPLX( AIR( I), AII( I))
      BCX= CMPLX( BIR( I), BII( I))
      CCX= CMPLX( CIR( I), CII( I))
      HX= HX+ EXK* ACX+ EXS* BCX+ EXC* CCX
      HY= HY+ EYK* ACX+ EYS* BCX+ EYC* CCX
    3 HZ= HZ+ EZK* ACX+ EZS* BCX+ EZC* CCX
      IF( M.EQ.0) RETURN
    4 JC= N
      JL= LD+1
      DO 5  I=1, M
      JL= JL-1
      S= BI( JL)
      XJ= X( JL)
      YJ= Y( JL)
      ZJ= Z( JL)
      T1XJ= T1X( JL)
      T1YJ= T1Y( JL)
      T1ZJ= T1Z( JL)
      T2XJ= T2X( JL)
      T2YJ= T2Y( JL)
      T2ZJ= T2Z( JL)
      CALL HINTG( XOB, YOB, ZOB)
      JC= JC+3
      ACX= T1XJ* CUR( JC-2)+ T1YJ* CUR( JC-1)+ T1ZJ* CUR( JC)
      BCX= T2XJ* CUR( JC-2)+ T2YJ* CUR( JC-1)+ T2ZJ* CUR( JC)
      HX= HX+ ACX* EXK+ BCX* EXS
      HY= HY+ ACX* EYK+ BCX* EYS
    5 HZ= HZ+ ACX* EZK+ BCX* EZS
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE PATCH( NX, NY, X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3, X4,
     & Y4, Z4)
C ***
C     PATCH GENERATES AND MODIFIES PATCH GEOMETRY DATA
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ANGL/ SALP( NM)
      DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
C     NEW PATCHES.  FOR NX=0, NY=1,2,3,4 PATCH IS (RESPECTIVELY)
C     ARBITRARY, RECTAGULAR, TRIANGULAR, OR QUADRILATERAL.
C     FOR NX AND NY .GT. 0 A RECTANGULAR SURFACE IS PRODUCED WITH
C     NX BY NY RECTANGULAR PATCHES.
      EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
     &T2Z,ITAG)
      M= M+1
      MI= LD+1- M
      NTP= NY
      IF( NX.GT.0) NTP=2
      IF( NTP.GT.1) GOTO 2
      X( MI)= X1
      Y( MI)= Y1
      Z( MI)= Z1
      BI( MI)= Z2
      ZNV= COS( X2)
      XNV= ZNV* COS( Y2)
      YNV= ZNV* SIN( Y2)
      ZNV= SIN( X2)
      XA= SQRT( XNV* XNV+ YNV* YNV)
      IF( XA.LT.1.D-6) GOTO 1
      T1X( MI)=- YNV/ XA
      T1Y( MI)= XNV/ XA
      T1Z( MI)=0.
      GOTO 6
    1 T1X( MI)=1.
      T1Y( MI)=0.
      T1Z( MI)=0.
      GOTO 6
    2 S1X= X2- X1
      S1Y= Y2- Y1
      S1Z= Z2- Z1
      S2X= X3- X2
      S2Y= Y3- Y2
      S2Z= Z3- Z2
      IF( NX.EQ.0) GOTO 3
      S1X= S1X/ NX
      S1Y= S1Y/ NX
      S1Z= S1Z/ NX
      S2X= S2X/ NY
      S2Y= S2Y/ NY
      S2Z= S2Z/ NY
    3 XNV= S1Y* S2Z- S1Z* S2Y
      YNV= S1Z* S2X- S1X* S2Z
      ZNV= S1X* S2Y- S1Y* S2X
      XA= SQRT( XNV* XNV+ YNV* YNV+ ZNV* ZNV)
      XNV= XNV/ XA
      YNV= YNV/ XA
      ZNV= ZNV/ XA
      XST= SQRT( S1X* S1X+ S1Y* S1Y+ S1Z* S1Z)
      T1X( MI)= S1X/ XST
      T1Y( MI)= S1Y/ XST
      T1Z( MI)= S1Z/ XST
      IF( NTP.GT.2) GOTO 4
      X( MI)= X1+.5*( S1X+ S2X)
      Y( MI)= Y1+.5*( S1Y+ S2Y)
      Z( MI)= Z1+.5*( S1Z+ S2Z)
      BI( MI)= XA
      GOTO 6
    4 IF( NTP.EQ.4) GOTO 5
      X( MI)=( X1+ X2+ X3)/3.
      Y( MI)=( Y1+ Y2+ Y3)/3.
      Z( MI)=( Z1+ Z2+ Z3)/3.
      BI( MI)=.5* XA
      GOTO 6
    5 S1X= X3- X1
      S1Y= Y3- Y1
      S1Z= Z3- Z1
      S2X= X4- X1
      S2Y= Y4- Y1
      S2Z= Z4- Z1
      XN2= S1Y* S2Z- S1Z* S2Y
      YN2= S1Z* S2X- S1X* S2Z
      ZN2= S1X* S2Y- S1Y* S2X
      XST= SQRT( XN2* XN2+ YN2* YN2+ ZN2* ZN2)
      SALPN=1./(3.*( XA+ XST))
      X( MI)=( XA*( X1+ X2+ X3)+ XST*( X1+ X3+ X4))* SALPN
      Y( MI)=( XA*( Y1+ Y2+ Y3)+ XST*( Y1+ Y3+ Y4))* SALPN
      Z( MI)=( XA*( Z1+ Z2+ Z3)+ XST*( Z1+ Z3+ Z4))* SALPN
      BI( MI)=.5*( XA+ XST)
      S1X=( XNV* XN2+ YNV* YN2+ ZNV* ZN2)/ XST
      IF( S1X.GT.0.9998) GOTO 6
      WRITE( 6,14)
      STOP
    6 T2X( MI)= YNV* T1Z( MI)- ZNV* T1Y( MI)
      T2Y( MI)= ZNV* T1X( MI)- XNV* T1Z( MI)
      T2Z( MI)= XNV* T1Y( MI)- YNV* T1X( MI)
      SALP( MI)=1.
      IF( NX.EQ.0) GOTO 8
      M= M+ NX* NY-1
      XN2= X( MI)- S1X- S2X
      YN2= Y( MI)- S1Y- S2Y
      ZN2= Z( MI)- S1Z- S2Z
      XS= T1X( MI)
      YS= T1Y( MI)
      ZS= T1Z( MI)
      XT= T2X( MI)
      YT= T2Y( MI)
      ZT= T2Z( MI)
      MI= MI+1
      DO 7  IY=1, NY
      XN2= XN2+ S2X
      YN2= YN2+ S2Y
      ZN2= ZN2+ S2Z
      DO 7  IX=1, NX
      XST= IX
      MI= MI-1
      X( MI)= XN2+ XST* S1X
      Y( MI)= YN2+ XST* S1Y
      Z( MI)= ZN2+ XST* S1Z
      BI( MI)= XA
      SALP( MI)=1.
      T1X( MI)= XS
      T1Y( MI)= YS
      T1Z( MI)= ZS
      T2X( MI)= XT
      T2Y( MI)= YT
    7 T2Z( MI)= ZT
    8 IPSYM=0
      NP= N
      MP= M
C     DIVIDE PATCH FOR WIRE CONNECTION
      RETURN
      ENTRY SUBPH( NX, NY, X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3, X4, Y4,
     &Z4)
      IF( NY.GT.0) GOTO 10
      IF( NX.EQ. M) GOTO 10
      NXP= NX+1
      IX= LD- M
      DO 9  IY= NXP, M
      IX= IX+1
      NYP= IX-3
      X( NYP)= X( IX)
      Y( NYP)= Y( IX)
      Z( NYP)= Z( IX)
      BI( NYP)= BI( IX)
      SALP( NYP)= SALP( IX)
      T1X( NYP)= T1X( IX)
      T1Y( NYP)= T1Y( IX)
      T1Z( NYP)= T1Z( IX)
      T2X( NYP)= T2X( IX)
      T2Y( NYP)= T2Y( IX)
    9 T2Z( NYP)= T2Z( IX)
   10 MI= LD+1- NX
      XS= X( MI)
      YS= Y( MI)
      ZS= Z( MI)
      XA= BI( MI)*.25
      XST= SQRT( XA)*.5
      S1X= T1X( MI)
      S1Y= T1Y( MI)
      S1Z= T1Z( MI)
      S2X= T2X( MI)
      S2Y= T2Y( MI)
      S2Z= T2Z( MI)
      SALN= SALP( MI)
      XT= XST
      YT= XST
      IF( NY.GT.0) GOTO 11
      MIA= MI
      GOTO 12
   11 M= M+1
      MP= MP+1
      MIA= LD+1- M
   12 DO 13  IX=1,4
      X( MIA)= XS+ XT* S1X+ YT* S2X
      Y( MIA)= YS+ XT* S1Y+ YT* S2Y
      Z( MIA)= ZS+ XT* S1Z+ YT* S2Z
      BI( MIA)= XA
      T1X( MIA)= S1X
      T1Y( MIA)= S1Y
      T1Z( MIA)= S1Z
      T2X( MIA)= S2X
      T2Y( MIA)= S2Y
      T2Z( MIA)= S2Z
      SALP( MIA)= SALN
      IF( IX.EQ.2) YT=- YT
      IF( IX.EQ.1.OR. IX.EQ.3) XT=- XT
      MIA= MIA-1
   13 CONTINUE
      M= M+3
      IF( NX.LE. MP) MP= MP+3
      IF( NY.GT.0) Z( MI)=10000.
C
      RETURN
   14 FORMAT(' ERROR -- CORNERS OF QUADRILATERAL PATCH DO NOT LIE IN ',
     &'A PLANE')
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE PCINT( XI, YI, ZI, CABI, SABI, SALPI, E)
C ***
C     INTEGRATE OVER PATCHES AT WIRE CONNECTION POINT
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, E, E1,
     &E2, E3, E4, E5, E6, E7, E8, E9
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, PGND
      DIMENSION  E(9)
      EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
     &IND1),(T2ZJ,IND2)
      DATA   TPI/6.283185308D+0/, NINT/10/
      D= SQRT( S)*.5
      DS=4.* D/ DFLOAT( NINT)
      DA= DS* DS
      GCON=1./ S
      FCON=1./(2.* TPI* D)
      XXJ= XJ
      XYJ= YJ
      XZJ= ZJ
      XS= S
      S= DA
      S1= D+ DS*.5
      XSS= XJ+ S1*( T1XJ+ T2XJ)
      YSS= YJ+ S1*( T1YJ+ T2YJ)
      ZSS= ZJ+ S1*( T1ZJ+ T2ZJ)
      S1= S1+ D
      S2X= S1
      E1=(0.,0.)
      E2=(0.,0.)
      E3=(0.,0.)
      E4=(0.,0.)
      E5=(0.,0.)
      E6=(0.,0.)
      E7=(0.,0.)
      E8=(0.,0.)
      E9=(0.,0.)
      DO 1  I1=1, NINT
      S1= S1- DS
      S2= S2X
      XSS= XSS- DS* T1XJ
      YSS= YSS- DS* T1YJ
      ZSS= ZSS- DS* T1ZJ
      XJ= XSS
      YJ= YSS
      ZJ= ZSS
      DO 1  I2=1, NINT
      S2= S2- DS
      XJ= XJ- DS* T2XJ
      YJ= YJ- DS* T2YJ
      ZJ= ZJ- DS* T2ZJ
      CALL UNERE( XI, YI, ZI)
      EXK= EXK* CABI+ EYK* SABI+ EZK* SALPI
      EXS= EXS* CABI+ EYS* SABI+ EZS* SALPI
      G1=( D+ S1)*( D+ S2)* GCON
      G2=( D- S1)*( D+ S2)* GCON
      G3=( D- S1)*( D- S2)* GCON
      G4=( D+ S1)*( D- S2)* GCON
      F2=( S1* S1+ S2* S2)* TPI
      F1= S1/ F2-( G1- G2- G3+ G4)* FCON
      F2= S2/ F2-( G1+ G2- G3- G4)* FCON
      E1= E1+ EXK* G1
      E2= E2+ EXK* G2
      E3= E3+ EXK* G3
      E4= E4+ EXK* G4
      E5= E5+ EXS* G1
      E6= E6+ EXS* G2
      E7= E7+ EXS* G3
      E8= E8+ EXS* G4
    1 E9= E9+ EXK* F1+ EXS* F2
      E(1)= E1
      E(2)= E2
      E(3)= E3
      E(4)= E4
      E(5)= E5
      E(6)= E6
      E(7)= E7
      E(8)= E8
      E(9)= E9
      XJ= XXJ
      YJ= XYJ
      ZJ= XZJ
      S= XS
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE PRNT( IN1, IN2, IN3, FL1, FL2, FL3, FL4, FL5, FL6, IA,
     & ICHAR)
C ***
C
C     PRNT SETS UP THE PRINT FORMATS FOR IMPEDANCE LOADING
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      REAL  IFORM, IVAR
      DIMENSION  IVAR(13), IA(1), IFORM(8), IN(3), INT(3), FL(6), FLT(6
     &)
      INTEGER  HALL
C
C     NUMBER OF CHARACTERS PER COMPUTER WORD IS NCPW
C
      DATA   IFORM/5H(/3X,,3HI5,,3H5X,,3HA5,,6HE13.4,,4H13X,,3H3X,,
     &4H5A4)/
      DATA   HALL/4H ALL/
      IN(1)= IN1
      IN(2)= IN2
      IN(3)= IN3
      FL(1)= FL1
      FL(2)= FL2
      FL(3)= FL3
      FL(4)= FL4
      FL(5)= FL5
C
C     INTEGER FORMAT
C
      FL(6)= FL6
      NINT=0
      IVAR(1)= IFORM(1)
      K=1
      I1=1
      IF(.NOT.( IN1.EQ.0.AND. IN2.EQ.0.AND. IN3.EQ.0)) GOTO 1
      INT(1)= HALL
      NINT=1
      I1=2
      K= K+1
      IVAR( K)= IFORM(4)
    1 DO 3  I= I1,3
      K= K+1
      IF( IN( I).EQ.0) GOTO 2
      NINT= NINT+1
      INT( NINT)= IN( I)
      IVAR( K)= IFORM(2)
      GOTO 3
    2 IVAR( K)= IFORM(3)
    3 CONTINUE
      K= K+1
C
C     DFLOATING POINT FORMAT
C
      IVAR( K)= IFORM(7)
      NFLT=0
      DO 5  I=1,6
      K= K+1
      IF( ABS( FL( I)).LT.1.D-20) GOTO 4
      NFLT= NFLT+1
      FLT( NFLT)= FL( I)
      IVAR( K)= IFORM(5)
      GOTO 5
    4 IVAR( K)= IFORM(6)
    5 CONTINUE
      K= K+1
      IVAR( K)= IFORM(7)
      K= K+1
      IVAR( K)= IFORM(8)
      WRITE( 6,IVAR) ( INT( I), I=1, NINT),( FLT( J), J=1, NFLT),( IA(
     &L), L=1, ICHAR)
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE QDSRC( IS, V, E)
C ***
C     FILL INCIDENT FIELD ARRAY FOR CHARGE DISCONTINUITY VOLTAGE SOURCE
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  VQDS, CURD, CCJ, V, EXK, EYK, EZK, EXS, EYS, EZS, EXC
     &, EYC, EZC, ETK, ETS, ETC, VSANT, VQD, E, ZARRAY
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
     &, IQDS(30), NVQD, NSANT, NQDS
      COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
     &NSCON, IPCON(10), NPCON
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      COMMON  /ANGL/ SALP( NM)
      COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
      DIMENSION  CCJX(2), E(1), CAB(1), SAB(1)
      DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
      EQUIVALENCE(CCJ,CCJX),(CAB,ALP),(SAB,BET)
      EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
     &T2Z,ITAG)
      DATA   TP/6.283185308D+0/, CCJX/0.,-.01666666667D+0/
      I= ICON1( IS)
      ICON1( IS)=0
      CALL TBF( IS,0)
      ICON1( IS)= I
      S= SI( IS)*.5
      CURD= CCJ* V/(( LOG(2.* S/ BI( IS))-1.)*( BX( JSNO)* COS( TP* S)+
     & CX( JSNO)* SIN( TP* S))* WLAM)
      NQDS= NQDS+1
      VQDS( NQDS)= V
      IQDS( NQDS)= IS
      DO 20  JX=1, JSNO
      J= JCO( JX)
      S= SI( J)
      B= BI( J)
      XJ= X( J)
      YJ= Y( J)
      ZJ= Z( J)
      CABJ= CAB( J)
      SABJ= SAB( J)
      SALPJ= SALP( J)
      IF( IEXK.EQ.0) GOTO 16
      IPR= ICON1( J)
      IF( IPR) 1,6,2
    1 IPR=- IPR
      IF(- ICON1( IPR).NE. J) GOTO 7
      GOTO 4
    2 IF( IPR.NE. J) GOTO 3
      IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 7
      GOTO 5
    3 IF( ICON2( IPR).NE. J) GOTO 7
    4 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
      IF( XI.LT.0.999999D+0) GOTO 7
      IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 7
    5 IND1=0
      GOTO 8
    6 IND1=1
      GOTO 8
    7 IND1=2
    8 IPR= ICON2( J)
      IF( IPR) 9,14,10
    9 IPR=- IPR
      IF(- ICON2( IPR).NE. J) GOTO 15
      GOTO 12
   10 IF( IPR.NE. J) GOTO 11
      IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 15
      GOTO 13
   11 IF( ICON1( IPR).NE. J) GOTO 15
   12 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
      IF( XI.LT.0.999999D+0) GOTO 15
      IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 15
   13 IND2=0
      GOTO 16
   14 IND2=1
      GOTO 16
   15 IND2=2
   16 CONTINUE
      DO 17  I=1, N
      IJ= I- J
      XI= X( I)
      YI= Y( I)
      ZI= Z( I)
      AI= BI( I)
      CALL EFLD( XI, YI, ZI, AI, IJ)
      CABI= CAB( I)
      SABI= SAB( I)
      SALPI= SALP( I)
      ETK= EXK* CABI+ EYK* SABI+ EZK* SALPI
      ETS= EXS* CABI+ EYS* SABI+ EZS* SALPI
      ETC= EXC* CABI+ EYC* SABI+ EZC* SALPI
   17 E( I)= E( I)-( ETK* AX( JX)+ ETS* BX( JX)+ ETC* CX( JX))* CURD
      IF( M.EQ.0) GOTO 19
      IJ= LD+1
      I1= N
      DO 18  I=1, M
      IJ= IJ-1
      XI= X( IJ)
      YI= Y( IJ)
      ZI= Z( IJ)
      CALL HSFLD( XI, YI, ZI,0.)
      I1= I1+1
      TX= T2X( IJ)
      TY= T2Y( IJ)
      TZ= T2Z( IJ)
      ETK= EXK* TX+ EYK* TY+ EZK* TZ
      ETS= EXS* TX+ EYS* TY+ EZS* TZ
      ETC= EXC* TX+ EYC* TY+ EZC* TZ
      E( I1)= E( I1)+( ETK* AX( JX)+ ETS* BX( JX)+ ETC* CX( JX))* CURD*
     & SALP( IJ)
      I1= I1+1
      TX= T1X( IJ)
      TY= T1Y( IJ)
      TZ= T1Z( IJ)
      ETK= EXK* TX+ EYK* TY+ EZK* TZ
      ETS= EXS* TX+ EYS* TY+ EZS* TZ
      ETC= EXC* TX+ EYC* TY+ EZC* TZ
   18 E( I1)= E( I1)+( ETK* AX( JX)+ ETS* BX( JX)+ ETC* CX( JX))* CURD*
     & SALP( IJ)
   19 IF( NLOAD.GT.0.OR. NLODF.GT.0) E( J)= E( J)+ ZARRAY( J)* CURD*(
     &AX( JX)+ CX( JX))
   20 CONTINUE
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE RDPAT
C ***
C     COMPUTE RADIATION PATTERN, GAIN, NORMALIZED GAIN
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
C     INTEGER HPOL,HBLK,HCIR,HCLIF
      REAL  IGNTP, IGAX, IGTP, HCIR, HBLK, HPOL, HCLIF, ISENS, COM
      COMPLEX  ETH, EPH, ERD, ZRATI, ZRATI2, T1, FRATI
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /SAVE/ IP( N2M), KCOM, COM(19,5), EPSR, SIG, SCRWLT,
     &SCRWRT, FMHZ
      COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
     &KSYMP, IFAR, IPERF, T1, T2
      COMMON  /FPAT/ NTH, NPH, IPD, IAVP, INOR, IAX, THETS, PHIS, DTH,
     &DPH, RFLD, GNOR, CLT, CHT, EPSR2, SIG2, IXTYP, XPR6, PINR, PNLR,
     &PLOSS, NEAR, NFEH, NRX, NRY, NRZ, XNR, YNR, ZNR, DXNR, DYNR, DZNR
     &
C***
      COMMON  /SCRATM/ GAIN(2*N2M)
C***
      COMMON  /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4
      DIMENSION  IGTP(4), IGAX(4), IGNTP(10), HPOL(3)
      DATA   HPOL/6HLINEAR,5HRIGHT,4HLEFT/, HBLK, HCIR/1H ,6HCIRCLE/
      DATA   IGTP/6H    - ,6HPOWER ,6H- DIRE,6HCTIVE /
      DATA   IGAX/6H MAJOR,6H MINOR,6H VERT.,6H HOR. /
      DATA   IGNTP/6H MAJOR,6H AXIS ,6H MINOR,6H AXIS ,6H   VER,
     &6HTICAL ,6H HORIZ,6HONTAL ,6H      ,6HTOTAL /
      DATA   PI, TA, TD/3.141592654D+0,1.745329252D-02,57.29577951D+0/
      DATA   NORMAX/1200/
      IF( IFAR.LT.2) GOTO 2
      WRITE( 6,35)
      IF( IFAR.LE.3) GOTO 1
      WRITE( 6,36)  NRADL, SCRWLT, SCRWRT
      IF( IFAR.EQ.4) GOTO 2
    1 IF( IFAR.EQ.2.OR. IFAR.EQ.5) HCLIF= HPOL(1)
      IF( IFAR.EQ.3.OR. IFAR.EQ.6) HCLIF= HCIR
      CL= CLT/ WLAM
      CH= CHT/ WLAM
      ZRATI2= SQRT(1./ CMPLX( EPSR2,- SIG2* WLAM*59.96))
      WRITE( 6,37)  HCLIF, CLT, CHT, EPSR2, SIG2
    2 IF( IFAR.NE.1) GOTO 3
      WRITE( 6,41)
      GOTO 5
    3 I=2* IPD+1
      J= I+1
      ITMP1=2* IAX+1
      ITMP2= ITMP1+1
      WRITE( 6,38)
      IF( RFLD.LT.1.D-20) GOTO 4
      EXRM=1./ RFLD
      EXRA= RFLD/ WLAM
      EXRA=-360.*( EXRA- AINT( EXRA))
      WRITE( 6,39)  RFLD, EXRM, EXRA
    4 WRITE( 6,40)  IGTP( I), IGTP( J), IGAX( ITMP1), IGAX( ITMP2)
    5 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) GOTO 7
      IF( IXTYP.EQ.4) GOTO 6
      PRAD=0.
      GCON=4.* PI/(1.+ XPR6* XPR6)
      GCOP= GCON
      GOTO 8
    6 PINR=394.51* XPR6* XPR6* WLAM* WLAM
    7 GCOP= WLAM* WLAM*2.* PI/(376.73* PINR)
      PRAD= PINR- PLOSS- PNLR
      GCON= GCOP
      IF( IPD.NE.0) GCON= GCON* PINR/ PRAD
    8 I=0
      GMAX=-1.E10
      PINT=0.
      TMP1= DPH* TA
      TMP2=.5* DTH* TA
      PHI= PHIS- DPH
      DO 29  KPH=1, NPH
      PHI= PHI+ DPH
      PHA= PHI* TA
      THET= THETS- DTH
      DO 29  KTH=1, NTH
      THET= THET+ DTH
      IF( KSYMP.EQ.2.AND. THET.GT.90.01.AND. IFAR.NE.1) GOTO 29
      THA= THET* TA
      IF( IFAR.EQ.1) GOTO 9
      CALL FFLD( THA, PHA, ETH, EPH)
      GOTO 10
    9 CALL GFLD( RFLD/ WLAM, PHA, THET/ WLAM, ETH, EPH, ERD, ZRATI,
     &KSYMP)
      ERDM= ABS( ERD)
      ERDA= CANG( ERD)
   10 ETHM2= REAL( ETH* CONJG( ETH))
      ETHM= SQRT( ETHM2)
      ETHA= CANG( ETH)
      EPHM2= REAL( EPH* CONJG( EPH))
      EPHM= SQRT( EPHM2)
      EPHA= CANG( EPH)
C     ELLIPTICAL POLARIZATION CALC.
      IF( IFAR.EQ.1) GOTO 28
      IF( ETHM2.GT.1.D-20.OR. EPHM2.GT.1.D-20) GOTO 11
      TILTA=0.
      EMAJR2=0.
      EMINR2=0.
      AXRAT=0.
      ISENS= HBLK
      GOTO 16
   11 DFAZ= EPHA- ETHA
      IF( EPHA.LT.0.) GOTO 12
      DFAZ2= DFAZ-360.
      GOTO 13
   12 DFAZ2= DFAZ+360.
   13 IF( ABS( DFAZ).GT. ABS( DFAZ2)) DFAZ= DFAZ2
      CDFAZ= COS( DFAZ* TA)
      TSTOR1= ETHM2- EPHM2
      TSTOR2=2.* EPHM* ETHM* CDFAZ
      TILTA=.5* ATGN2( TSTOR2, TSTOR1)
      STILTA= SIN( TILTA)
      TSTOR1= TSTOR1* STILTA* STILTA
      TSTOR2= TSTOR2* STILTA* COS( TILTA)
      EMAJR2=- TSTOR1+ TSTOR2+ ETHM2
      EMINR2= TSTOR1- TSTOR2+ EPHM2
      IF( EMINR2.LT.0.) EMINR2=0.
      AXRAT= SQRT( EMINR2/ EMAJR2)
      TILTA= TILTA* TD
      IF( AXRAT.GT.1.D-5) GOTO 14
      ISENS= HPOL(1)
      GOTO 16
   14 IF( DFAZ.GT.0.) GOTO 15
      ISENS= HPOL(2)
      GOTO 16
   15 ISENS= HPOL(3)
   16 GNMJ= DB10( GCON* EMAJR2)
      GNMN= DB10( GCON* EMINR2)
      GNV= DB10( GCON* ETHM2)
      GNH= DB10( GCON* EPHM2)
      GTOT= DB10( GCON*( ETHM2+ EPHM2))
      IF( INOR.LT.1) GOTO 23
      I= I+1
      IF( I.GT. NORMAX) GOTO 23
      GOTO (17,18,19,20,21), INOR
   17 TSTOR1= GNMJ
      GOTO 22
   18 TSTOR1= GNMN
      GOTO 22
   19 TSTOR1= GNV
      GOTO 22
   20 TSTOR1= GNH
      GOTO 22
   21 TSTOR1= GTOT
   22 GAIN( I)= TSTOR1
      IF( TSTOR1.GT. GMAX) GMAX= TSTOR1
   23 IF( IAVP.EQ.0) GOTO 24
      TSTOR1= GCOP*( ETHM2+ EPHM2)
      TMP3= THA- TMP2
      TMP4= THA+ TMP2
      IF( KTH.EQ.1) TMP3= THA
      IF( KTH.EQ. NTH) TMP4= THA
      DA= ABS( TMP1*( COS( TMP3)- COS( TMP4)))
      IF( KPH.EQ.1.OR. KPH.EQ. NPH) DA=.5* DA
      PINT= PINT+ TSTOR1* DA
      IF( IAVP.EQ.2) GOTO 29
   24 IF( IAX.EQ.1) GOTO 25
      TMP5= GNMJ
      TMP6= GNMN
      GOTO 26
   25 TMP5= GNV
      TMP6= GNH
   26 ETHM= ETHM* WLAM
      EPHM= EPHM* WLAM
      IF( RFLD.LT.1.D-20) GOTO 27
      ETHM= ETHM* EXRM
      ETHA= ETHA+ EXRA
      EPHM= EPHM* EXRM
      EPHA= EPHA+ EXRA
C      GO TO 29
C***
C28    WRITE(6,43)  RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA
   27 WRITE( 6,42)  THET, PHI, TMP5, TMP6, GTOT, AXRAT, TILTA, ISENS,
     ÐM, ETHA, EPHM, EPHA
      IF( IPLP1.NE.3) GOTO 299
      IF( IPLP3.EQ.0) GOTO 290
      IF( IPLP2.EQ.1.AND. IPLP3.EQ.1) WRITE( 8,*)  THET, ETHM, ETHA
      IF( IPLP2.EQ.1.AND. IPLP3.EQ.2) WRITE( 8,*)  THET, EPHM, EPHA
      IF( IPLP2.EQ.2.AND. IPLP3.EQ.1) WRITE( 8,*)  PHI, ETHM, ETHA
      IF( IPLP2.EQ.2.AND. IPLP3.EQ.2) WRITE( 8,*)  PHI, EPHM, EPHA
      IF( IPLP4.EQ.0) GOTO 299
  290 IF( IPLP2.EQ.1.AND. IPLP4.EQ.1) WRITE( 8,*)  THET, TMP5
      IF( IPLP2.EQ.1.AND. IPLP4.EQ.2) WRITE( 8,*)  THET, TMP6
      IF( IPLP2.EQ.1.AND. IPLP4.EQ.3) WRITE( 8,*)  THET, GTOT
      IF( IPLP2.EQ.2.AND. IPLP4.EQ.1) WRITE( 8,*)  PHI, TMP5
      IF( IPLP2.EQ.2.AND. IPLP4.EQ.2) WRITE( 8,*)  PHI, TMP6
      IF( IPLP2.EQ.2.AND. IPLP4.EQ.3) WRITE( 8,*)  PHI, GTOT
      GOTO 299
   28 WRITE( 6,43)  RFLD, PHI, THET, ETHM, ETHA, EPHM, EPHA, ERDM, ERDA
     &
C***
  299 CONTINUE
   29 CONTINUE
      IF( IAVP.EQ.0) GOTO 30
      TMP3= THETS* TA
      TMP4= TMP3+ DTH* TA* DFLOAT( NTH-1)
      TMP3= ABS( DPH* TA* DFLOAT( NPH-1)*( COS( TMP3)- COS( TMP4)))
      PINT= PINT/ TMP3
      TMP3= TMP3/ PI
      WRITE( 6,44)  PINT, TMP3
   30 IF( INOR.EQ.0) GOTO 34
      IF( ABS( GNOR).GT.1.D-20) GMAX= GNOR
      ITMP1=( INOR-1)*2+1
      ITMP2= ITMP1+1
      WRITE( 6,45)  IGNTP( ITMP1), IGNTP( ITMP2), GMAX
      ITMP2= NPH* NTH
      IF( ITMP2.GT. NORMAX) ITMP2= NORMAX
      ITMP1=( ITMP2+2)/3
      ITMP2= ITMP1*3- ITMP2
      ITMP3= ITMP1
      ITMP4=2* ITMP1
      IF( ITMP2.EQ.2) ITMP4= ITMP4-1
      DO 31  I=1, ITMP1
      ITMP3= ITMP3+1
      ITMP4= ITMP4+1
      J=( I-1)/ NTH
      TMP1= THETS+ DFLOAT( I- J* NTH-1)* DTH
      TMP2= PHIS+ DFLOAT( J)* DPH
      J=( ITMP3-1)/ NTH
      TMP3= THETS+ DFLOAT( ITMP3- J* NTH-1)* DTH
      TMP4= PHIS+ DFLOAT( J)* DPH
      J=( ITMP4-1)/ NTH
      TMP5= THETS+ DFLOAT( ITMP4- J* NTH-1)* DTH
      TMP6= PHIS+ DFLOAT( J)* DPH
      TSTOR1= GAIN( I)- GMAX
      IF( I.EQ. ITMP1.AND. ITMP2.NE.0) GOTO 32
      TSTOR2= GAIN( ITMP3)- GMAX
      PINT= GAIN( ITMP4)- GMAX
   31 WRITE( 6,46)  TMP1, TMP2, TSTOR1, TMP3, TMP4, TSTOR2, TMP5, TMP6,
     & PINT
      GOTO 34
   32 IF( ITMP2.EQ.2) GOTO 33
      TSTOR2= GAIN( ITMP3)- GMAX
      WRITE( 6,46)  TMP1, TMP2, TSTOR1, TMP3, TMP4, TSTOR2
      GOTO 34
   33 WRITE( 6,46)  TMP1, TMP2, TSTOR1
C
   34 RETURN
   35 FORMAT(///,31X,'- - - FAR FIELD GROUND PARAMETERS - - -',//)
   36 FORMAT(40X,'RADIAL WIRE GROUND SCREEN',/,40X,I5,' WIRES',/,40X,
     &'WIRE LENGTH=',F8.2,' METERS',/,40X,'WIRE RADIUS=',1P,E10.3,
     &' METERS')
   37 FORMAT(40X,A6,' CLIFF',/,40X,'EDGE DISTANCE=',F9.2,' METERS',/,40
     &X,'HEIGHT=',F8.2,' METERS',/,40X,'SECOND MEDIUM -',/,40X,'RELA',
     &'TIVE DIELECTRIC CONST.=',F7.3,/,40X,'CONDUCTIVITY=',1P,E10.3,
     &' MHOS')
   38 FORMAT(///,48X,'- - - RADIATION PATTERNS - - -')
   39 FORMAT(54X,'RANGE=',1P,E13.6,' METERS',/,54X,'EXP(-JKR)/R=',E12.5
     &,' AT PHASE',0P,F7.2,' DEGREES',/)
   40 FORMAT(/,2X,'- - ANGLES - -',7X,2A6,'GAINS -',7X,'- - - POLARI',
     &'ZATION - - -',4X,'- - - E(THETA) - - -',4X,'- - - E(PHI) - -',
     &' -',/,2X,'THETA',5X,'PHI',7X,A6,2X,A6,3X,'TOTAL',6X,'AXIAL',5X,
     &'TILT',3X,'SENSE',2(5X,'MAGNITUDE',4X,'PHASE'),/,2(1X,'DEGREES',1
     &X),3(6X,'DB'),8X,'RATIO',5X,'DEG.',8X,2(6X,'VOLTS/M',4X,'DEGRE',
     &'ES'))
   41 FORMAT(///,28X,' - - - RADIATED FIELDS NEAR GROUND - - -',//,8X,
     &'- - - LOCATION - - -',10X,'- - E(THETA) - -',8X,'- - E(PHI) -'
     &' -',8X,'- - E(RADIAL) - -',/,7X,'RHO',6X,'PHI',9X,'Z',12X,'MAG',
     &6X,'PHASE',9X,'MAG',6X,'PHASE',9X,'MAG',6X,'PHASE',/,5X,'METERS',
     &3X,'DEGREES',4X,'METERS',8X,'VOLTS/M',3X,'DEGREES',6X,'VOLTS/M',3
     &X,'DEGREES',6X,'VOLTS/M',3X,'DEGREES',/)
   42 FORMAT(1X,F7.2,F9.2,3X,3F8.2,F11.5,F9.2,2X,A6,2(1P,E15.5,0P,F9.2)
     &)
   43 FORMAT(3X,F9.2,2X,F7.2,2X,F9.2,1X,3(3X,1P,E11.4,2X,0P,F7.2))
   44 FORMAT(//,3X,'AVERAGE POWER GAIN=',1P,E12.5,7X,'SOLID ANGLE U',
     &'SED IN AVERAGING=(',0P,F7.4,')*PI STERADIANS.',//)
   45 FORMAT(//,37X,'- - - - NORMALIZED GAIN - - - -',//,37X,2A6,'GAI',
     &'N',/,38X,'NORMALIZATION FACTOR =',F9.2,' DB',//,3(4X,
     &'- - ANGLES'' - -',6X,'GAIN',7X),/,3(4X,'THETA',5X,'PHI',8X,'DB',
     &8X),/,3(3X,'DEGREES',2X,'DEGREES',16X))
   46 FORMAT(3(1X,2F9.2,1X,F9.2,6X))
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE READGM( GM, I1, I2, X1, Y1, Z1, X2, Y2, Z2, RAD)
C ***
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      INTEGER*4 NTOT
      INTEGER*4 NINT
      INTEGER*4 NFLT
      PARAMETER (NTOT=9, NINT=2, NFLT=7)
      INTEGER  IARR( NINT), BP( NTOT), EP( NTOT)
      DIMENSION  RARR( NFLT)
      CHARACTER   LINE*133, GM*2, BUFFER*132, BUFFER1*132
      READ( 5,10)  LINE
   10 FORMAT(A)
      NLIN= LEN(LINE)
      CALL STR0PC( LINE(1: NLIN), LINE(1: NLIN))
      IF( NLIN.LT.2) GOTO 110
      IF( NLIN.LE.132) GOTO 20
      NLIN=132
      LINE(133:133)=' '
   20 GM= LINE(1:2)
      NLIN= NLIN+1
      DO 30  I=1, NINT
   30 IARR( I)=0
      DO 40  I=1, NFLT
   40 RARR( I)=0.0
      IC=2
      IFOUND=0
      DO 70  I=1, NTOT
   50 IC= IC+1
      IF( IC.GE. NLIN) GOTO 80
      IF( LINE( IC: IC).EQ.' '.OR. LINE( IC: IC).EQ.',') GOTO 50
C BEGINNING OF I-TH NUMERICAL FIELD
      BP( I)= IC
   60 IC= IC+1
      IF( IC.GT. NLIN) GOTO 80
      IF( LINE( IC: IC).NE.' '.AND. LINE( IC: IC).NE.',') GOTO 60
C END OF I-TH NUMERICAL FIELD
      EP( I)= IC-1
      IFOUND= I
   70 CONTINUE
   80 CONTINUE
      DO 90  I=1, MIN( IFOUND, NINT)
      NLEN= EP( I)- BP( I)+1
      BUFFER= LINE( BP( I): EP( I))
      IND= INDEX( BUFFER(1: NLEN),'.')
      IF( IND.GT.0.AND. IND.LT. NLEN) GOTO 110
C USER PUT DECIMAL POINT FOR INTEGER
      IF( IND.EQ. NLEN) NLEN= NLEN-1
      READ( BUFFER(1: NLEN),111,ERR=110)  IARR( I)
111   format(i3)
   90 CONTINUE
      DO 100  I= NINT+1, IFOUND
      NLEN= EP( I)- BP( I)+1
      BUFFER= LINE( BP( I): EP( I))
      IND= INDEX( BUFFER(1: NLEN),'.')
C USER FORGOT DECIMAL POINT FOR REAL
      IF( IND.EQ.0) THEN
      IF( NLEN.GE.15) GOTO 110
      INDE= INDEX( BUFFER(1: NLEN),'E')
      NLEN= NLEN+1
      IF( INDE.EQ.0) THEN
      BUFFER( NLEN: NLEN)='.'
      ELSE
      BUFFER1= BUFFER(1: INDD-1)//'.'// BUFFER( INDE: NLEN-1)
      BUFFER= BUFFER1
      ENDIF
      ENDIF
      READ( BUFFER(1: NLEN),112,ERR=110)  RARR( I- NINT)
  112 format (F15.7)
  100 CONTINUE
      I1= IARR(1)
      I2= IARR(2)
      X1= RARR(1)
      Y1= RARR(2)
      Z1= RARR(3)
      X2= RARR(4)
      Y2= RARR(5)
      Z2= RARR(6)
      RAD= RARR(7)
      RETURN
  110 WRITE( 6,*) ' GEOMETRY DATA CARD ERROR'
      WRITE( 6,*)  LINE(1: MAX(1, NLIN-1))
      STOP
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE READMN( GM, I1, I2, I3, I4, F1, F2, F3, F4, F5, F6)
C ***
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      INTEGER*4 NTOT
      INTEGER*4 NINT
      INTEGER*4 NFLT
      PARAMETER (NTOT=10, NINT=4, NFLT=6)
      INTEGER  IARR( NINT), BP( NTOT), EP( NTOT)
      DIMENSION  RARR( NFLT)
      CHARACTER   LINE*133, GM*2, BUFFER*132, BUFFER1*132
      READ( 5,10)  LINE
   10 FORMAT(A)
      NLIN= LEN(LINE)
      CALL STR0PC( LINE(1: NLIN), LINE(1: NLIN))
      IF( NLIN.LT.2) GOTO 110
      IF( NLIN.LE.132) GOTO 20
      NLIN=132
      LINE(133:133)=' '
   20 GM= LINE(1:2)
      NLIN= NLIN+1
      DO 30  I=1, NINT
   30 IARR( I)=0
      DO 40  I=1, NFLT
   40 RARR( I)=0.0
      IC=2
      IFOUND=0
      DO 70  I=1, NTOT
   50 IC= IC+1
      IF( IC.GE. NLIN) GOTO 80
      IF( LINE( IC: IC).EQ.' '.OR. LINE( IC: IC).EQ.',') GOTO 50
C BEGINNING OF I-TH NUMERICAL FIELD
      BP( I)= IC
   60 IC= IC+1
      IF( IC.GT. NLIN) GOTO 80
      IF( LINE( IC: IC).NE.' '.AND. LINE( IC: IC).NE.',') GOTO 60
C END OF I-TH NUMERICAL FIELD
      EP( I)= IC-1
      IFOUND= I
   70 CONTINUE
   80 CONTINUE
      DO 90  I=1, MIN( IFOUND, NINT)
      NLEN= EP( I)- BP( I)+1
      BUFFER= LINE( BP( I): EP( I))
      IND= INDEX( BUFFER(1: NLEN),'.')
      IF( IND.GT.0.AND. IND.LT. NLEN) GOTO 110
C USER PUT DECIMAL POINT FOR INTEGER
      IF( IND.EQ. NLEN) NLEN= NLEN-1
      READ( BUFFER(1: NLEN),111,ERR=110)  IARR( I)
  111 format(I5)
   90 CONTINUE
      DO 100  I= NINT+1, IFOUND
      NLEN= EP( I)- BP( I)+1
      BUFFER= LINE( BP( I): EP( I))
      IND= INDEX( BUFFER(1: NLEN),'.')
C USER FORGOT DECIMAL POINT FOR REAL
      IF( IND.EQ.0) THEN
      IF( NLEN.GE.15) GOTO 110
      INDE= INDEX( BUFFER(1: NLEN),'E')
      NLEN= NLEN+1
      IF( INDE.EQ.0) THEN
      BUFFER( NLEN: NLEN)='.'
      ELSE
      BUFFER1= BUFFER(1: INDD-1)//'.'// BUFFER( INDE: NLEN-1)
      BUFFER= BUFFER1
      ENDIF
      ENDIF
      READ( BUFFER(1: NLEN),112,ERR=110)  RARR( I- NINT)
  112 format(F15.7)
  100 CONTINUE
      I1= IARR(1)
      I2= IARR(2)
      I3= IARR(3)
      I4= IARR(4)
      F1= RARR(1)
      F2= RARR(2)
      F3= RARR(3)
      F4= RARR(4)
      F5= RARR(5)
      F6= RARR(6)
      RETURN
  110 WRITE( 6,*) '          FAULTY DATA CARD AFTER GEOMETRY SECTION'
      WRITE( 6,*)  LINE(1: MAX(1, NLIN-1))
      STOP
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE REBLK( B, BX, NB, NBX, N2C)
C ***
C     REBLOCK ARRAY B IN N.G.F. SOLUTION FROM BLOCKS OF ROWS ON TAPE14
C     TO BLOCKS OF COLUMNS ON TAPE16
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  B, BX
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      DIMENSION  B( NB,1), BX( NBX,1)
      REWIND 16
      NIB=0
      NPB= NPBL
      DO 3  IB=1, NBBL
      IF( IB.EQ. NBBL) NPB= NLBL
      REWIND 14
      NIX=0
      NPX= NPBX
      DO 2  IBX=1, NBBX
      IF( IBX.EQ. NBBX) NPX= NLBX
      READ( 14) (( BX( I, J), I=1, NPX), J=1, N2C)
      DO 1  I=1, NPX
      IX= I+ NIX
      DO 1  J=1, NPB
    1 B( IX, J)= BX( I, J+ NIB)
    2 NIX= NIX+ NPBX
      WRITE( 16) (( B( I, J), I=1, NB), J=1, NPB)
    3 NIB= NIB+ NPBL
      REWIND 14
      REWIND 16
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE REFLC( IX, IY, IZ, ITX, NOP)
C ***
C
C     REFLC REFLECTS PARTIAL STRUCTURE ALONG X,Y, OR Z AXES OR ROTATES
C     STRUCTURE TO COMPLETE A SYMMETRIC STRUCTURE.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /ANGL/ SALP( NM)
      DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), X2(1),
     & Y2(1), Z2(1)
      EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
     &T2Z,ITAG),(X2,SI),(Y2,ALP),(Z2,BET)
      NP= N
      MP= M
      IPSYM=0
      ITI= ITX
      IF( IX.LT.0) GOTO 19
      IF( NOP.EQ.0) RETURN
      IPSYM=1
C
C     REFLECT ALONG Z AXIS
C
      IF( IZ.EQ.0) GOTO 6
      IPSYM=2
      IF( N.LT. N2) GOTO 3
      DO 2  I= N2, N
      NX= I+ N- N1
      E1= Z( I)
      E2= Z2( I)
      IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 1
      WRITE( 6,24)  I
      STOP
    1 X( NX)= X( I)
      Y( NX)= Y( I)
      Z( NX)=- E1
      X2( NX)= X2( I)
      Y2( NX)= Y2( I)
      Z2( NX)=- E2
      ITAGI= ITAG( I)
      IF( ITAGI.EQ.0) ITAG( NX)=0
      IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI
    2 BI( NX)= BI( I)
      N= N*2- N1
      ITI= ITI*2
    3 IF( M.LT. M2) GOTO 6
      NXX= LD+1- M1
      DO 5  I= M2, M
      NXX= NXX-1
      NX= NXX- M+ M1
      IF( ABS( Z( NXX)).GT.1.D-10) GOTO 4
      WRITE( 6,25)  I
      STOP
    4 X( NX)= X( NXX)
      Y( NX)= Y( NXX)
      Z( NX)=- Z( NXX)
      T1X( NX)= T1X( NXX)
      T1Y( NX)= T1Y( NXX)
      T1Z( NX)=- T1Z( NXX)
      T2X( NX)= T2X( NXX)
      T2Y( NX)= T2Y( NXX)
      T2Z( NX)=- T2Z( NXX)
      SALP( NX)=- SALP( NXX)
    5 BI( NX)= BI( NXX)
      M= M*2- M1
C
C     REFLECT ALONG Y AXIS
C
    6 IF( IY.EQ.0) GOTO 12
      IF( N.LT. N2) GOTO 9
      DO 8  I= N2, N
      NX= I+ N- N1
      E1= Y( I)
      E2= Y2( I)
      IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 7
      WRITE( 6,24)  I
      STOP
    7 X( NX)= X( I)
      Y( NX)=- E1
      Z( NX)= Z( I)
      X2( NX)= X2( I)
      Y2( NX)=- E2
      Z2( NX)= Z2( I)
      ITAGI= ITAG( I)
      IF( ITAGI.EQ.0) ITAG( NX)=0
      IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI
    8 BI( NX)= BI( I)
      N= N*2- N1
      ITI= ITI*2
    9 IF( M.LT. M2) GOTO 12
      NXX= LD+1- M1
      DO 11  I= M2, M
      NXX= NXX-1
      NX= NXX- M+ M1
      IF( ABS( Y( NXX)).GT.1.D-10) GOTO 10
      WRITE( 6,25)  I
      STOP
   10 X( NX)= X( NXX)
      Y( NX)=- Y( NXX)
      Z( NX)= Z( NXX)
      T1X( NX)= T1X( NXX)
      T1Y( NX)=- T1Y( NXX)
      T1Z( NX)= T1Z( NXX)
      T2X( NX)= T2X( NXX)
      T2Y( NX)=- T2Y( NXX)
      T2Z( NX)= T2Z( NXX)
      SALP( NX)=- SALP( NXX)
   11 BI( NX)= BI( NXX)
      M= M*2- M1
C
C     REFLECT ALONG X AXIS
C
   12 IF( IX.EQ.0) GOTO 18
      IF( N.LT. N2) GOTO 15
      DO 14  I= N2, N
      NX= I+ N- N1
      E1= X( I)
      E2= X2( I)
      IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 13
      WRITE( 6,24)  I
      STOP
   13 X( NX)=- E1
      Y( NX)= Y( I)
      Z( NX)= Z( I)
      X2( NX)=- E2
      Y2( NX)= Y2( I)
      Z2( NX)= Z2( I)
      ITAGI= ITAG( I)
      IF( ITAGI.EQ.0) ITAG( NX)=0
      IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI
   14 BI( NX)= BI( I)
      N= N*2- N1
   15 IF( M.LT. M2) GOTO 18
      NXX= LD+1- M1
      DO 17  I= M2, M
      NXX= NXX-1
      NX= NXX- M+ M1
      IF( ABS( X( NXX)).GT.1.D-10) GOTO 16
      WRITE( 6,25)  I
      STOP
   16 X( NX)=- X( NXX)
      Y( NX)= Y( NXX)
      Z( NX)= Z( NXX)
      T1X( NX)=- T1X( NXX)
      T1Y( NX)= T1Y( NXX)
      T1Z( NX)= T1Z( NXX)
      T2X( NX)=- T2X( NXX)
      T2Y( NX)= T2Y( NXX)
      T2Z( NX)= T2Z( NXX)
      SALP( NX)=- SALP( NXX)
   17 BI( NX)= BI( NXX)
      M= M*2- M1
C
C     REPRODUCE STRUCTURE WITH ROTATION TO FORM CYLINDRICAL STRUCTURE
C
   18 RETURN
   19 FNOP= NOP
      IPSYM=-1
      SAM=6.283185308D+0/ FNOP
      CS= COS( SAM)
      SS= SIN( SAM)
      IF( N.LT. N2) GOTO 21
      N= N1+( N- N1)* NOP
      NX= NP+1
      DO 20  I= NX, N
      K= I- NP+ N1
      XK= X( K)
      YK= Y( K)
      X( I)= XK* CS- YK* SS
      Y( I)= XK* SS+ YK* CS
      Z( I)= Z( K)
      XK= X2( K)
      YK= Y2( K)
      X2( I)= XK* CS- YK* SS
      Y2( I)= XK* SS+ YK* CS
      Z2( I)= Z2( K)
      ITAGI= ITAG( K)
      IF( ITAGI.EQ.0) ITAG( I)=0
      IF( ITAGI.NE.0) ITAG( I)= ITAGI+ ITI
   20 BI( I)= BI( K)
   21 IF( M.LT. M2) GOTO 23
      M= M1+( M- M1)* NOP
      NX= MP+1
      K= LD+1- M1
      DO 22  I= NX, M
      K= K-1
      J= K- MP+ M1
      XK= X( K)
      YK= Y( K)
      X( J)= XK* CS- YK* SS
      Y( J)= XK* SS+ YK* CS
      Z( J)= Z( K)
      XK= T1X( K)
      YK= T1Y( K)
      T1X( J)= XK* CS- YK* SS
      T1Y( J)= XK* SS+ YK* CS
      T1Z( J)= T1Z( K)
      XK= T2X( K)
      YK= T2Y( K)
      T2X( J)= XK* CS- YK* SS
      T2Y( J)= XK* SS+ YK* CS
      T2Z( J)= T2Z( K)
      SALP( J)= SALP( K)
   22 BI( J)= BI( K)
C
   23 RETURN
   24 FORMAT(' GEOMETRY DATA ERROR--SEGMENT,I5,26H LIES IN PLANE OF S',
     &'YMMETRY')
   25 FORMAT(' GEOMETRY DATA ERROR--PATCH,I4,26H LIES IN PLANE OF SYM',
     &'METRY')
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE ROM2( A, B, SUM, DMIN)
C ***
C
C     FOR THE SOMMERFELD GROUND OPTION, ROM2 INTEGRATES OVER THE SOURCE
C     SEGMENT TO OBTAIN THE TOTAL FIELD DUE TO GROUND.  THE METHOD OF
C     VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION IS USED.  THERE ARE 9
C     FIELD COMPONENTS - THE X, Y, AND Z COMPONENTS DUE TO CONSTANT,
C     SINE, AND COSINE CURRENT DISTRIBUTIONS.
C
      IMPLICIT REAL (A-H,O-Z)
      COMPLEX  SUM, G1, G2, G3, G4, G5, T00, T01, T10, T02, T11, T20
     &
      DIMENSION  SUM(9), G1(9), G2(9), G3(9), G4(9), G5(9), T01(9), T10
     &(9), T20(9)
      DATA   NM, NTS, NX, N/65536,4,1,9/, RX/1.D-4/
      Z= A
      ZE= B
      S= B- A
      IF( S.GE.0.) GOTO 1
      WRITE( 6,18)
      STOP
    1 EP= S/(1.E4* NM)
      ZEND= ZE- EP
      DO 2  I=1, N
    2 SUM( I)=(0.,0.)
      NS= NX
      NT=0
      CALL SFLDS( Z, G1)
    3 DZ= S/ NS
      IF( Z+ DZ.LE. ZE) GOTO 4
      DZ= ZE- Z
      IF( DZ.LE. EP) GOTO 17
    4 DZOT= DZ*.5
      CALL SFLDS( Z+ DZOT, G3)
      CALL SFLDS( Z+ DZ, G5)
    5 TMAG1=0.
C
C     EVALUATE 3 POINT ROMBERG RESULT AND TEST CONVERGENCE.
C
      TMAG2=0.
      DO 6  I=1, N
      T00=( G1( I)+ G5( I))* DZOT
      T01( I)=( T00+ DZ* G3( I))*.5
      T10( I)=(4.* T01( I)- T00)/3.
      IF( I.GT.3) GOTO 6
      TR= REAL( T01( I))
      TI= AIMAG( T01( I))
      TMAG1= TMAG1+ TR* TR+ TI* TI
      TR= REAL( T10( I))
      TI= AIMAG( T10( I))
      TMAG2= TMAG2+ TR* TR+ TI* TI
    6 CONTINUE
      TMAG1= SQRT( TMAG1)
      TMAG2= SQRT( TMAG2)
      CALL TEST( TMAG1, TMAG2, TR,0.,0., TI, DMIN)
      IF( TR.GT. RX) GOTO 8
      DO 7  I=1, N
    7 SUM( I)= SUM( I)+ T10( I)
      NT= NT+2
      GOTO 12
    8 CALL SFLDS( Z+ DZ*.25, G2)
      CALL SFLDS( Z+ DZ*.75, G4)
      TMAG1=0.
C
C     EVALUATE 5 POINT ROMBERG RESULT AND TEST CONVERGENCE.
C
      TMAG2=0.
      DO 9  I=1, N
      T02=( T01( I)+ DZOT*( G2( I)+ G4( I)))*.5
      T11=(4.* T02- T01( I))/3.
      T20( I)=(16.* T11- T10( I))/15.
      IF( I.GT.3) GOTO 9
      TR= REAL( T11)
      TI= AIMAG( T11)
      TMAG1= TMAG1+ TR* TR+ TI* TI
      TR= REAL( T20( I))
      TI= AIMAG( T20( I))
      TMAG2= TMAG2+ TR* TR+ TI* TI
    9 CONTINUE
      TMAG1= SQRT( TMAG1)
      TMAG2= SQRT( TMAG2)
      CALL TEST( TMAG1, TMAG2, TR,0.,0., TI, DMIN)
      IF( TR.GT. RX) GOTO 14
   10 DO 11  I=1, N
   11 SUM( I)= SUM( I)+ T20( I)
      NT= NT+1
   12 Z= Z+ DZ
      IF( Z.GT. ZEND) GOTO 17
      DO 13  I=1, N
   13 G1( I)= G5( I)
      IF( NT.LT. NTS.OR. NS.LE. NX) GOTO 3
      NS= NS/2
      NT=1
      GOTO 3
   14 NT=0
      IF( NS.LT. NM) GOTO 15
      WRITE( 6,19)  Z
      GOTO 10
   15 NS= NS*2
      DZ= S/ NS
      DZOT= DZ*.5
      DO 16  I=1, N
      G5( I)= G3( I)
   16 G3( I)= G2( I)
      GOTO 5
   17 CONTINUE
C
      RETURN
   18 FORMAT(' ERROR - B LESS THAN A IN ROM2')
   19 FORMAT(' ROM2 -- STEP SIZE LIMITED AT Z =',1P,E12.5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE SBF( I, IS, AA, BB, CC)
C ***
C     COMPUTE COMPONENT OF BASIS FUNCTION I ON SEGMENT IS.
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      DATA   PI/3.141592654D+0/, JMAX/30/
      AA=0.
      BB=0.
      CC=0.
      JUNE=0
      JSNO=0
      PP=0.
      JCOX= ICON1( I)
      IF( JCOX.GT.10000) JCOX= I
      JEND=-1
      IEND=-1
      SIG=-1.
      IF( JCOX) 1,11,2
    1 JCOX=- JCOX
      GOTO 3
    2 SIG=- SIG
      JEND=- JEND
    3 JSNO= JSNO+1
      IF( JSNO.GE. JMAX) GOTO 24
      D= PI* SI( JCOX)
      SDH= SIN( D)
      CDH= COS( D)
      SD=2.* SDH* CDH
      IF( D.GT.0.015) GOTO 4
      OMC=4.* D* D
      OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC
      GOTO 5
    4 OMC=1.- CDH* CDH+ SDH* SDH
    5 AJ=1./( LOG(1./( PI* BI( JCOX)))-.577215664D+0)
      PP= PP- OMC/ SD* AJ
      IF( JCOX.NE. IS) GOTO 6
      AA= AJ/ SD* SIG
      BB= AJ/(2.* CDH)
      CC=- AJ/(2.* SDH)* SIG
      JUNE= IEND
    6 IF( JCOX.EQ. I) GOTO 9
      IF( JEND.EQ.1) GOTO 7
      JCOX= ICON1( JCOX)
      GOTO 8
    7 JCOX= ICON2( JCOX)
    8 IF( IABS( JCOX).EQ. I) GOTO 10
      IF( JCOX) 1,24,2
    9 IF( JCOX.EQ. IS) BB=- BB
   10 IF( IEND.EQ.1) GOTO 12
   11 PM=- PP
      PP=0.
      NJUN1= JSNO
      JCOX= ICON2( I)
      IF( JCOX.GT.10000) JCOX= I
      JEND=1
      IEND=1
      SIG=-1.
      IF( JCOX) 1,12,2
   12 NJUN2= JSNO- NJUN1
      D= PI* SI( I)
      SDH= SIN( D)
      CDH= COS( D)
      SD=2.* SDH* CDH
      CD= CDH* CDH- SDH* SDH
      IF( D.GT.0.015) GOTO 13
      OMC=4.* D* D
      OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC
      GOTO 14
   13 OMC=1.- CD
   14 AP=1./( LOG(1./( PI* BI( I)))-.577215664D+0)
      AJ= AP
      IF( NJUN1.EQ.0) GOTO 19
      IF( NJUN2.EQ.0) GOTO 21
      QP= SD*( PM* PP+ AJ* AP)+ CD*( PM* AP- PP* AJ)
      QM=( AP* OMC- PP* SD)/ QP
      QP=-( AJ* OMC+ PM* SD)/ QP
      IF( JUNE) 15,18,16
   15 AA= AA* QM
      BB= BB* QM
      CC= CC* QM
      GOTO 17
   16 AA=- AA* QP
      BB= BB* QP
      CC=- CC* QP
   17 IF( I.NE. IS) RETURN
   18 AA= AA-1.
      BB= BB+( AJ* QM+ AP* QP)* SDH/ SD
      CC= CC+( AJ* QM- AP* QP)* CDH/ SD
      RETURN
   19 IF( NJUN2.EQ.0) GOTO 23
      QP= PI* BI( I)
      XXI= QP* QP
      XXI= QP*(1.-.5* XXI)/(1.- XXI)
      QP=-( OMC+ XXI* SD)/( SD*( AP+ XXI* PP)+ CD*( XXI* AP- PP))
      IF( JUNE.NE.1) GOTO 20
      AA=- AA* QP
      BB= BB* QP
      CC=- CC* QP
      IF( I.NE. IS) RETURN
   20 AA= AA-1.
      D= CD- XXI* SD
      BB= BB+( SDH+ AP* QP*( CDH- XXI* SDH))/ D
      CC= CC+( CDH+ AP* QP*( SDH+ XXI* CDH))/ D
      RETURN
   21 QM= PI* BI( I)
      XXI= QM* QM
      XXI= QM*(1.-.5* XXI)/(1.- XXI)
      QM=( OMC+ XXI* SD)/( SD*( AJ- XXI* PM)+ CD*( PM+ XXI* AJ))
      IF( JUNE.NE.-1) GOTO 22
      AA= AA* QM
      BB= BB* QM
      CC= CC* QM
      IF( I.NE. IS) RETURN
   22 AA= AA-1.
      D= CD- XXI* SD
      BB= BB+( AJ* QM*( CDH- XXI* SDH)- SDH)/ D
      CC= CC+( CDH- AJ* QM*( SDH+ XXI* CDH))/ D
      RETURN
   23 AA=-1.
      QP= PI* BI( I)
      XXI= QP* QP
      XXI= QP*(1.-.5* XXI)/(1.- XXI)
      CC=1./( CDH- XXI* SDH)
      RETURN
   24 WRITE( 6,25)  I
C
      STOP
   25 FORMAT(' SBF - SEGMENT CONNECTION ERROR FOR SEGMENT',I5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE SFLDS( T, E)
C ***
C
C     SFLDX RETURNS THE FIELD DUE TO GROUND FOR A CURRENT ELEMENT ON
C     THE SOURCE SEGMENT AT T RELATIVE TO THE SEGMENT CENTER.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  E, ERV, EZV, ERH, EZH, EPH, T1, EXK, EYK, EZK, EXS,
     &EYS, EZS, EXC, EYC, EZC, XX1, XX2, U, U2, ZRATI, ZRATI2, FRATI,
     &ER, ET, HRV, HZV, HRH
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      COMMON  /INCOM/ XO, YO, ZO, SN, XSN, YSN, ISNOR
      COMMON  /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH
      COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
     &KSYMP, IFAR, IPERF, T1, T2
      DIMENSION  E(9)
      DATA   PI/3.141592654D+0/, TP/6.283185308D+0/, POT/1.570796327D+0
     &/
      XT= XJ+ T* CABJ
      YT= YJ+ T* SABJ
      ZT= ZJ+ T* SALPJ
      RHX= XO- XT
      RHY= YO- YT
      RHS= RHX* RHX+ RHY* RHY
      RHO= SQRT( RHS)
      IF( RHO.GT.0.) GOTO 1
      RHX=1.
      RHY=0.
      PHX=0.
      PHY=1.
      GOTO 2
    1 RHX= RHX/ RHO
      RHY= RHY/ RHO
      PHX=- RHY
      PHY= RHX
    2 CPH= RHX* XSN+ RHY* YSN
      SPH= RHY* XSN- RHX* YSN
      IF( ABS( CPH).LT.1.D-10) CPH=0.
      IF( ABS( SPH).LT.1.D-10) SPH=0.
      ZPH= ZO+ ZT
      ZPHS= ZPH* ZPH
      R2S= RHS+ ZPHS
      R2= SQRT( R2S)
      RK= R2* TP
      XX2= CMPLX( COS( RK),- SIN( RK))
C
C     USE NORTON APPROXIMATION FOR FIELD DUE TO GROUND.  CURRENT IS
C     LUMPED AT SEGMENT CENTER WITH CURRENT MOMENT FOR CONSTANT, SINE,
C     OR COSINE DISTRIBUTION.
C
      IF( ISNOR.EQ.1) GOTO 3
      ZMH=1.
      R1=1.
      XX1=0.
      CALL GWAVE( ERV, EZV, ERH, EZH, EPH)
      ET=-(0.,4.77134)* FRATI* XX2/( R2S* R2)
      ER=2.* ET* CMPLX(1.0, RK)
      ET= ET* CMPLX(1.0 - RK* RK, RK)
      HRV=( ER+ ET)* RHO* ZPH/ R2S
      HZV=( ZPHS* ER- RHS* ET)/ R2S
      HRH=( RHS* ER- ZPHS* ET)/ R2S
      ERV= ERV- HRV
      EZV= EZV- HZV
      ERH= ERH+ HRH
      EZH= EZH+ HRV
      EPH= EPH+ ET
      ERV= ERV* SALPJ
      EZV= EZV* SALPJ
      ERH= ERH* SN* CPH
      EZH= EZH* SN* CPH
      EPH= EPH* SN* SPH
      ERH= ERV+ ERH
      E(1)=( ERH* RHX+ EPH* PHX)* S
      E(2)=( ERH* RHY+ EPH* PHY)* S
      E(3)=( EZV+ EZH)* S
      E(4)=0.
      E(5)=0.
      E(6)=0.
      SFAC= PI* S
      SFAC= SIN( SFAC)/ SFAC
      E(7)= E(1)* SFAC
      E(8)= E(2)* SFAC
      E(9)= E(3)* SFAC
C
C     INTERPOLATE IN SOMMERFELD FIELD TABLES
C
      RETURN
    3 IF( RHO.LT.1.D-12) GOTO 4
      THET= ATAN( ZPH/ RHO)
      GOTO 5
    4 THET= POT
C     COMBINE VERTICAL AND HORIZONTAL COMPONENTS AND CONVERT TO X,Y,Z
C     COMPONENTS.  MULTIPLY BY EXP(-JKR)/R.
    5 CALL INTRP( R2, THET, ERV, EZV, ERH, EPH)
      XX2= XX2/ R2
      SFAC= SN* CPH
      ERH= XX2*( SALPJ* ERV+ SFAC* ERH)
      EZH= XX2*( SALPJ* EZV- SFAC* ERV)
C     X,Y,Z FIELDS FOR CONSTANT CURRENT
      EPH= SN* SPH* XX2* EPH
      E(1)= ERH* RHX+ EPH* PHX
      E(2)= ERH* RHY+ EPH* PHY
      E(3)= EZH
C     X,Y,Z FIELDS FOR SINE CURRENT
      RK= TP* T
      SFAC= SIN( RK)
      E(4)= E(1)* SFAC
      E(5)= E(2)* SFAC
C     X,Y,Z FIELDS FOR COSINE CURRENT
      E(6)= E(3)* SFAC
      SFAC= COS( RK)
      E(7)= E(1)* SFAC
      E(8)= E(2)* SFAC
      E(9)= E(3)* SFAC
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE SOLGF( A, B, C, D, XY, IP, NP, N1, N, MP, M1, M, N1C,
     &N2C, N2CZ)
C ***
C     SOLVE FOR CURRENT IN N.G.F. PROCEDURE
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  A, B, C, D, SUM, XY, Y
      COMMON  /SCRATM/ Y( N2M)
      COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
     &NSCON, IPCON(10), NPCON
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      DIMENSION  A(1), B( N1C,1), C( N1C,1), D( N2CZ,1), IP(1), XY(1)
      IFL=14
      IF( ICASX.GT.0) IFL=13
C     NORMAL SOLUTION.  NOT N.G.F.
      IF( N2C.GT.0) GOTO 1
      CALL SOLVES( A, IP, XY, N1C,1, NP, N, MP, M,13, IFL)
      GOTO 22
C     REORDER EXCITATION ARRAY
    1 IF( N1.EQ. N.OR. M1.EQ.0) GOTO 5
      N2= N1+1
      JJ= N+1
      NPM= N+2* M1
      DO 2  I= N2, NPM
    2 Y( I)= XY( I)
      J= N1
      DO 3  I= JJ, NPM
      J= J+1
    3 XY( J)= Y( I)
      DO 4  I= N2, N
      J= J+1
    4 XY( J)= Y( I)
    5 NEQS= NSCON+2* NPCON
      IF( NEQS.EQ.0) GOTO 7
      NEQ= N1C+ N2C
C     COMPUTE INV(A)E1
      NEQS= NEQ- NEQS+1
      DO 6  I= NEQS, NEQ
    6 XY( I)=(0.,0.)
    7 CALL SOLVES( A, IP, XY, N1C,1, NP, N1, MP, M1,13, IFL)
      NI=0
C     COMPUTE E2-C(INV(A)E1)
      NPB= NPBL
      DO 10  JJ=1, NBBL
      IF( JJ.EQ. NBBL) NPB= NLBL
      IF( ICASX.GT.1) READ( 15) (( C( I, J), I=1, N1C), J=1, NPB)
      II= N1C+ NI
      DO 9  I=1, NPB
      SUM=(0.,0.)
      DO 8  J=1, N1C
    8 SUM= SUM+ C( J, I)* XY( J)
      J= II+ I
    9 XY( J)= XY( J)- SUM
   10 NI= NI+ NPBL
      REWIND 15
C     COMPUTE INV(D)(E2-C(INV(A)E1)) = I2
      JJ= N1C+1
      IF( ICASX.GT.1) GOTO 11
      CALL SOLVE( N2C, D, IP( JJ), XY( JJ), N2C)
      GOTO 13
   11 IF( ICASX.EQ.4) GOTO 12
      NI= N2C* N2C
      READ( 11) ( B( J,1), J=1, NI)
      REWIND 11
      CALL SOLVE( N2C, B, IP( JJ), XY( JJ), N2C)
      GOTO 13
   12 NBLSYS= NBLSYM
      NPSYS= NPSYM
      NLSYS= NLSYM
      ICASS= ICASE
      NBLSYM= NBBL
      NPSYM= NPBL
      NLSYM= NLBL
      ICASE=3
      REWIND 11
      REWIND 16
      CALL LTSOLV( B, N2C, IP( JJ), XY( JJ), N2C,1,11,16)
      REWIND 11
      REWIND 16
      NBLSYM= NBLSYS
      NPSYM= NPSYS
      NLSYM= NLSYS
      ICASE= ICASS
   13 NI=0
C     COMPUTE INV(A)E1-(INV(A)B)I2 = I1
      NPB= NPBL
      DO 16  JJ=1, NBBL
      IF( JJ.EQ. NBBL) NPB= NLBL
      IF( ICASX.GT.1) READ( 14) (( B( I, J), I=1, N1C), J=1, NPB)
      II= N1C+ NI
      DO 15  I=1, N1C
      SUM=(0.,0.)
      DO 14  J=1, NPB
      JP= II+ J
   14 SUM= SUM+ B( I, J)* XY( JP)
   15 XY( I)= XY( I)- SUM
   16 NI= NI+ NPBL
      REWIND 14
C     REORDER CURRENT ARRAY
      IF( N1.EQ. N.OR. M1.EQ.0) GOTO 20
      DO 17  I= N2, NPM
   17 Y( I)= XY( I)
      JJ= N1C+1
      J= N1
      DO 18  I= JJ, NPM
      J= J+1
   18 XY( J)= Y( I)
      DO 19  I= N2, N1C
      J= J+1
   19 XY( J)= Y( I)
   20 IF( NSCON.EQ.0) GOTO 22
      J= NEQS-1
      DO 21  I=1, NSCON
      J= J+1
      JJ= ISCON( I)
   21 XY( JJ)= XY( J)
   22 RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE SOLVE( N, A, IP, B, NDIM)
C ***
C
C     SUBROUTINE TO SOLVE THE MATRIX EQUATION LU*X=B WHERE L IS A UNIT
C     LOWER TRIANGULAR MATRIX AND U IS AN UPPER TRIANGULAR MATRIX BOTH
C     OF WHICH ARE STORED IN A.  THE RHS VECTOR B IS INPUT AND THE
C     SOLUTION IS RETURNED THROUGH VECTOR B.    (MATRIX TRANSPOSED.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  A, B, Y, SUM
      INTEGER  PI
      COMMON  /SCRATM/ Y( N2M)
C
C     FORWARD SUBSTITUTION
C
      DIMENSION  A( NDIM, NDIM), IP( NDIM), B( NDIM)
      DO 3  I=1, N
      PI= IP( I)
      Y( I)= B( PI)
      B( PI)= B( I)
      IP1= I+1
      IF( IP1.GT. N) GOTO 2
      DO 1  J= IP1, N
      B( J)= B( J)- A( I, J)* Y( I)
    1 CONTINUE
    2 CONTINUE
C
C     BACKWARD SUBSTITUTION
C
    3 CONTINUE
      DO 6  K=1, N
      I= N- K+1
      SUM=(0.,0.)
      IP1= I+1
      IF( IP1.GT. N) GOTO 5
      DO 4  J= IP1, N
      SUM= SUM+ A( J, I)* B( J)
    4 CONTINUE
    5 CONTINUE
      B( I)=( Y( I)- SUM)/ A( I, I)
    6 CONTINUE
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE SOLVES( A, IP, B, NEQ, NRH, NP, N, MP, M, IFL1, IFL2)
C ***
C
C     SUBROUTINE SOLVES, FOR SYMMETRIC STRUCTURES, HANDLES THE
C     TRANSFORMATION OF THE RIGHT HAND SIDE VECTOR AND SOLUTION OF THE
C     MATRIX EQ.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  A, B, Y, SUM, SSX
      COMMON  /SMAT/ SSX(16,16)
      COMMON  /SCRATM/ Y( N2M)
      COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM,
     &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
      DIMENSION  A(1), IP(1), B( NEQ, NRH)
      NPEQ= NP+2* MP
      NOP= NEQ/ NPEQ
      FNOP= NOP
      FNORM=1./ FNOP
      NROW= NEQ
      IF( ICASE.GT.3) NROW= NPEQ
      IF( NOP.EQ.1) GOTO 11
      DO 10  IC=1, NRH
      IF( N.EQ.0.OR. M.EQ.0) GOTO 6
      DO 1  I=1, NEQ
    1 Y( I)= B( I, IC)
      KK=2* MP
      IA= NP
      IB= N
      J= NP
      DO 5  K=1, NOP
      IF( K.EQ.1) GOTO 3
      DO 2  I=1, NP
      IA= IA+1
      J= J+1
    2 B( J, IC)= Y( IA)
      IF( K.EQ. NOP) GOTO 5
    3 DO 4  I=1, KK
      IB= IB+1
      J= J+1
    4 B( J, IC)= Y( IB)
C
C     TRANSFORM MATRIX EQ. RHS VECTOR ACCORDING TO SYMMETRY MODES
C
    5 CONTINUE
    6 DO 10  I=1, NPEQ
      DO 7  K=1, NOP
      IA= I+( K-1)* NPEQ
    7 Y( K)= B( IA, IC)
      SUM= Y(1)
      DO 8  K=2, NOP
    8 SUM= SUM+ Y( K)
      B( I, IC)= SUM* FNORM
      DO 10  K=2, NOP
      IA= I+( K-1)* NPEQ
      SUM= Y(1)
      DO 9  J=2, NOP
    9 SUM= SUM+ Y( J)* CONJG( SSX( K, J))
   10 B( IA, IC)= SUM* FNORM
   11 IF( ICASE.LT.3) GOTO 12
      REWIND IFL1
C
C     SOLVE EACH MODE EQUATION
C
      REWIND IFL2
   12 DO 16  KK=1, NOP
      IA=( KK-1)* NPEQ+1
      IB= IA
      IF( ICASE.NE.4) GOTO 13
      I= NPEQ* NPEQ
      READ( IFL1) ( A( J), J=1, I)
      IB=1
   13 IF( ICASE.EQ.3.OR. ICASE.EQ.5) GOTO 15
      DO 14  IC=1, NRH
   14 CALL SOLVE( NPEQ, A( IB), IP( IA), B( IA, IC), NROW)
      GOTO 16
   15 CALL LTSOLV( A, NPEQ, IP( IA), B( IA,1), NEQ, NRH, IFL1, IFL2)
   16 CONTINUE
C
C     INVERSE TRANSFORM THE MODE SOLUTIONS
C
      IF( NOP.EQ.1) RETURN
      DO 26  IC=1, NRH
      DO 20  I=1, NPEQ
      DO 17  K=1, NOP
      IA= I+( K-1)* NPEQ
   17 Y( K)= B( IA, IC)
      SUM= Y(1)
      DO 18  K=2, NOP
   18 SUM= SUM+ Y( K)
      B( I, IC)= SUM
      DO 20  K=2, NOP
      IA= I+( K-1)* NPEQ
      SUM= Y(1)
      DO 19  J=2, NOP
   19 SUM= SUM+ Y( J)* SSX( K, J)
   20 B( IA, IC)= SUM
      IF( N.EQ.0.OR. M.EQ.0) GOTO 26
      DO 21  I=1, NEQ
   21 Y( I)= B( I, IC)
      KK=2* MP
      IA= NP
      IB= N
      J= NP
      DO 25  K=1, NOP
      IF( K.EQ.1) GOTO 23
      DO 22  I=1, NP
      IA= IA+1
      J= J+1
   22 B( IA, IC)= Y( J)
      IF( K.EQ. NOP) GOTO 25
   23 DO 24  I=1, KK
      IB= IB+1
      J= J+1
   24 B( IB, IC)= Y( J)
   25 CONTINUE
   26 CONTINUE
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE TBF( I, ICAP)
C ***
C     COMPUTE BASIS FUNCTION I
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
     &NSCON, IPCON(10), NPCON
      DATA   PI/3.141592654D+0/, JMAX/30/
      JSNO=0
      PP=0.
      JCOX= ICON1( I)
      IF( JCOX.GT.10000) JCOX= I
      JEND=-1
      IEND=-1
      SIG=-1.
      IF( JCOX) 1,10,2
    1 JCOX=- JCOX
      GOTO 3
    2 SIG=- SIG
      JEND=- JEND
    3 JSNO= JSNO+1
      IF( JSNO.GE. JMAX) GOTO 28
      JCO( JSNO)= JCOX
      D= PI* SI( JCOX)
      SDH= SIN( D)
      CDH= COS( D)
      SD=2.* SDH* CDH
      IF( D.GT.0.015) GOTO 4
      OMC=4.* D* D
      OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC
      GOTO 5
    4 OMC=1.- CDH* CDH+ SDH* SDH
    5 AJ=1./( LOG(1./( PI* BI( JCOX)))-.577215664D+0)
      PP= PP- OMC/ SD* AJ
      AX( JSNO)= AJ/ SD* SIG
      BX( JSNO)= AJ/(2.* CDH)
      CX( JSNO)=- AJ/(2.* SDH)* SIG
      IF( JCOX.EQ. I) GOTO 8
      IF( JEND.EQ.1) GOTO 6
      JCOX= ICON1( JCOX)
      GOTO 7
    6 JCOX= ICON2( JCOX)
    7 IF( IABS( JCOX).EQ. I) GOTO 9
      IF( JCOX) 1,28,2
    8 BX( JSNO)=- BX( JSNO)
    9 IF( IEND.EQ.1) GOTO 11
   10 PM=- PP
      PP=0.
      NJUN1= JSNO
      JCOX= ICON2( I)
      IF( JCOX.GT.10000) JCOX= I
      JEND=1
      IEND=1
      SIG=-1.
      IF( JCOX) 1,11,2
   11 NJUN2= JSNO- NJUN1
      JSNOP= JSNO+1
      JCO( JSNOP)= I
      D= PI* SI( I)
      SDH= SIN( D)
      CDH= COS( D)
      SD=2.* SDH* CDH
      CD= CDH* CDH- SDH* SDH
      IF( D.GT.0.015) GOTO 12
      OMC=4.* D* D
      OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC
      GOTO 13
   12 OMC=1.- CD
   13 AP=1./( LOG(1./( PI* BI( I)))-.577215664D+0)
      AJ= AP
      IF( NJUN1.EQ.0) GOTO 16
      IF( NJUN2.EQ.0) GOTO 20
      QP= SD*( PM* PP+ AJ* AP)+ CD*( PM* AP- PP* AJ)
      QM=( AP* OMC- PP* SD)/ QP
      QP=-( AJ* OMC+ PM* SD)/ QP
      BX( JSNOP)=( AJ* QM+ AP* QP)* SDH/ SD
      CX( JSNOP)=( AJ* QM- AP* QP)* CDH/ SD
      DO 14  IEND=1, NJUN1
      AX( IEND)= AX( IEND)* QM
      BX( IEND)= BX( IEND)* QM
   14 CX( IEND)= CX( IEND)* QM
      JEND= NJUN1+1
      DO 15  IEND= JEND, JSNO
      AX( IEND)=- AX( IEND)* QP
      BX( IEND)= BX( IEND)* QP
   15 CX( IEND)=- CX( IEND)* QP
      GOTO 27
   16 IF( NJUN2.EQ.0) GOTO 24
      IF( ICAP.NE.0) GOTO 17
      XXI=0.
      GOTO 18
   17 QP= PI* BI( I)
      XXI= QP* QP
      XXI= QP*(1.-.5* XXI)/(1.- XXI)
   18 QP=-( OMC+ XXI* SD)/( SD*( AP+ XXI* PP)+ CD*( XXI* AP- PP))
      D= CD- XXI* SD
      BX( JSNOP)=( SDH+ AP* QP*( CDH- XXI* SDH))/ D
      CX( JSNOP)=( CDH+ AP* QP*( SDH+ XXI* CDH))/ D
      DO 19  IEND=1, NJUN2
      AX( IEND)=- AX( IEND)* QP
      BX( IEND)= BX( IEND)* QP
   19 CX( IEND)=- CX( IEND)* QP
      GOTO 27
   20 IF( ICAP.NE.0) GOTO 21
      XXI=0.
      GOTO 22
   21 QM= PI* BI( I)
      XXI= QM* QM
      XXI= QM*(1.-.5* XXI)/(1.- XXI)
   22 QM=( OMC+ XXI* SD)/( SD*( AJ- XXI* PM)+ CD*( PM+ XXI* AJ))
      D= CD- XXI* SD
      BX( JSNOP)=( AJ* QM*( CDH- XXI* SDH)- SDH)/ D
      CX( JSNOP)=( CDH- AJ* QM*( SDH+ XXI* CDH))/ D
      DO 23  IEND=1, NJUN1
      AX( IEND)= AX( IEND)* QM
      BX( IEND)= BX( IEND)* QM
   23 CX( IEND)= CX( IEND)* QM
      GOTO 27
   24 BX( JSNOP)=0.
      IF( ICAP.NE.0) GOTO 25
      XXI=0.
      GOTO 26
   25 QP= PI* BI( I)
      XXI= QP* QP
      XXI= QP*(1.-.5* XXI)/(1.- XXI)
   26 CX( JSNOP)=1./( CDH- XXI* SDH)
   27 JSNO= JSNOP
      AX( JSNO)=-1.
      RETURN
   28 WRITE( 6,29)  I
C
      STOP
   29 FORMAT(' TBF - SEGMENT CONNECTION ERROR FOR SEGMENT',I5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE TEST( F1R, F2R, TR, F1I, F2I, TI, DMIN)
C ***
C
C     TEST FOR CONVERGENCE IN NUMERICAL INTEGRATION
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      DEN= ABS( F2R)
      TR= ABS( F2I)
      IF( DEN.LT. TR) DEN= TR
      IF( DEN.LT. DMIN) DEN= DMIN
      IF( DEN.LT.1.D-37) GOTO 1
      TR= ABS(( F1R- F2R)/ DEN)
      TI= ABS(( F1I- F2I)/ DEN)
      RETURN
    1 TR=0.
      TI=0.
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE TRIO( J)
C ***
C     COMPUTE THE COMPONENTS OF ALL BASIS FUNCTIONS ON SEGMENT J
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50),
     &NSCON, IPCON(10), NPCON
      DATA   JMAX/30/
      JSNO=0
      JCOX= ICON1( J)
      IF( JCOX.GT.10000) GOTO 7
      JEND=-1
      IEND=-1
      IF( JCOX) 1,7,2
    1 JCOX=- JCOX
      GOTO 3
    2 JEND=- JEND
    3 IF( JCOX.EQ. J) GOTO 6
      JSNO= JSNO+1
      IF( JSNO.GE. JMAX) GOTO 9
      CALL SBF( JCOX, J, AX( JSNO), BX( JSNO), CX( JSNO))
      JCO( JSNO)= JCOX
      IF( JEND.EQ.1) GOTO 4
      JCOX= ICON1( JCOX)
      GOTO 5
    4 JCOX= ICON2( JCOX)
    5 IF( JCOX) 1,9,2
    6 IF( IEND.EQ.1) GOTO 8
    7 JCOX= ICON2( J)
      IF( JCOX.GT.10000) GOTO 8
      JEND=1
      IEND=1
      IF( JCOX) 1,8,2
    8 JSNO= JSNO+1
      CALL SBF( J, J, AX( JSNO), BX( JSNO), CX( JSNO))
      JCO( JSNO)= J
      RETURN
    9 WRITE( 6,10)  J
C
      STOP
   10 FORMAT(' TRIO - SEGMENT CONNENTION ERROR FOR SEGMENT',I5)
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE UNERE( XOB, YOB, ZOB)
C ***
C     CALCULATES THE ELECTRIC FIELD DUE TO UNIT CURRENT IN THE T1 AND T2
C     DIRECTIONS ON A PATCH
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMPLEX  EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, ZRATI,
     &ZRATI2, T1, ER, Q1, Q2, RRV, RRH, EDP, FRATI
      COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK,
     &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2,
     &INDD2, IPGND
      COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL,
     &KSYMP, IFAR, IPERF, T1, T2
      EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
     &IND1),(T2ZJ,IND2)
C     CONST=ETA/(8.*PI**2)
      DATA   TPI, CONST/6.283185308D+0,4.771341188D+0/
      ZR= ZJ
      T1ZR= T1ZJ
      T2ZR= T2ZJ
      IF( IPGND.NE.2) GOTO 1
      ZR=- ZR
      T1ZR=- T1ZR
      T2ZR=- T2ZR
    1 RX= XOB- XJ
      RY= YOB- YJ
      RZ= ZOB- ZR
      R2= RX* RX+ RY* RY+ RZ* RZ
      IF( R2.GT.1.D-20) GOTO 2
      EXK=(0.,0.)
      EYK=(0.,0.)
      EZK=(0.,0.)
      EXS=(0.,0.)
      EYS=(0.,0.)
      EZS=(0.,0.)
      RETURN
    2 R= SQRT( R2)
      TT1=- TPI* R
      TT2= TT1* TT1
      RT= R2* R
      ER= CMPLX( SIN( TT1),- COS( TT1))*( CONST* S)
      Q1= CMPLX( TT2-1., TT1)* ER/ RT
      Q2= CMPLX(3.- TT2,-3.* TT1)* ER/( RT* R2)
      ER= Q2*( T1XJ* RX+ T1YJ* RY+ T1ZR* RZ)
      EXK= Q1* T1XJ+ ER* RX
      EYK= Q1* T1YJ+ ER* RY
      EZK= Q1* T1ZR+ ER* RZ
      ER= Q2*( T2XJ* RX+ T2YJ* RY+ T2ZR* RZ)
      EXS= Q1* T2XJ+ ER* RX
      EYS= Q1* T2YJ+ ER* RY
      EZS= Q1* T2ZR+ ER* RZ
      IF( IPGND.EQ.1) GOTO 6
      IF( IPERF.NE.1) GOTO 3
      EXK=- EXK
      EYK=- EYK
      EZK=- EZK
      EXS=- EXS
      EYS=- EYS
      EZS=- EZS
      GOTO 6
    3 XYMAG= SQRT( RX* RX+ RY* RY)
      IF( XYMAG.GT.1.D-6) GOTO 4
      PX=0.
      PY=0.
      CTH=1.
      RRV=(1.,0.)
      GOTO 5
    4 PX=- RY/ XYMAG
      PY= RX/ XYMAG
      CTH= RZ/ SQRT( XYMAG* XYMAG+ RZ* RZ)
      RRV= SQRT(1.- ZRATI* ZRATI*(1.- CTH* CTH))
    5 RRH= ZRATI* CTH
      RRH=( RRH- RRV)/( RRH+ RRV)
      RRV= ZRATI* RRV
      RRV=-( CTH- RRV)/( CTH+ RRV)
      EDP=( EXK* PX+ EYK* PY)*( RRH- RRV)
      EXK= EXK* RRV+ EDP* PX
      EYK= EYK* RRV+ EDP* PY
      EZK= EZK* RRV
      EDP=( EXS* PX+ EYS* PY)*( RRH- RRV)
      EXS= EXS* RRV+ EDP* PX
      EYS= EYS* RRV+ EDP* PY
      EZS= EZS* RRV
    6 RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      SUBROUTINE WIRE( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, RDEL, RRAD,
     &NS, ITG)
C ***
C
C     SUBROUTINE WIRE GENERATES SEGMENT GEOMETRY DATA FOR A STRAIGHT
C     WIRE OF NS SEGMENTS.
C
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER ( NM=600, N2M=800, N3M=1000)
      COMMON  /DATA/ LD, N1, N2, N, NP, M1, M2, M, MP, X( NM), Y( NM),
     &Z( NM), SI( NM), BI( NM), ALP( NM), BET( NM), ICON1( N2M), ICON2(
     & N2M), ITAG( N2M), ICONX( NM), WLAM, IPSYM
      DIMENSION  X2(1), Y2(1), Z2(1)
      EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1))
      IST= N+1
      N= N+ NS
      NP= N
      MP= M
      IPSYM=0
      IF( NS.LT.1) RETURN
      XD= XW2- XW1
      YD= YW2- YW1
      ZD= ZW2- ZW1
      IF( ABS( RDEL-1.).LT.1.D-6) GOTO 1
      DELZ= SQRT( XD* XD+ YD* YD+ ZD* ZD)
      XD= XD/ DELZ
      YD= YD/ DELZ
      ZD= ZD/ DELZ
      DELZ= DELZ*(1.- RDEL)/(1.- RDEL** NS)
      RD= RDEL
      GOTO 2
    1 FNS= NS
      XD= XD/ FNS
      YD= YD/ FNS
      ZD= ZD/ FNS
      DELZ=1.
      RD=1.
    2 RADZ= RAD
      XS1= XW1
      YS1= YW1
      ZS1= ZW1
      DO 3  I= IST, N
      ITAG( I)= ITG
      XS2= XS1+ XD* DELZ
      YS2= YS1+ YD* DELZ
      ZS2= ZS1+ ZD* DELZ
      X( I)= XS1
      Y( I)= YS1
      Z( I)= ZS1
      X2( I)= XS2
      Y2( I)= YS2
      Z2( I)= ZS2
      BI( I)= RADZ
      DELZ= DELZ* RD
      RADZ= RADZ* RRAD
      XS1= XS2
      YS1= YS2
    3 ZS1= ZS2
      X2( N)= XW2
      Y2( N)= YW2
      Z2( N)= ZW2
      RETURN
      END
C ***
C     DOUBLE PRECISION 6/4/85
C
      FUNCTION ZINT( SIGL, ROLAM)
C ***
C
C     ZINT COMPUTES THE INTERNAL IMPEDANCE OF A CIRCULAR WIRE
C
C
      IMPLICIT REAL (A-H,O-Z)
      COMPLEX  TH, PH, F, G, FJ, CN, BR1, BR2, ZINT
      COMPLEX  CC1, CC2, CC3, CC4, CC5, CC6, CC7, CC8, CC9, CC10,
     &CC11, CC12, CC13, CC14
      DIMENSION  FJX(2), CNX(2), CCN(28)
      EQUIVALENCE(FJ,FJX),(CN,CNX),(CC1,CCN(1)),(CC2,CCN(3)),(CC3,CCN(5
     &)),(CC4,CCN(7)),(CC5,CCN(9)),(CC6,CCN(11)),(CC7,CCN(13)),(CC8,CCN
     &(15)),(CC9,CCN(17)),(CC10,CCN(19)),(CC11,CCN(21)),(CC12,CCN(23)),
     &(CC13,CCN(25)),(CC14,CCN(27))
      DATA   PI, POT, TP, TPCMU/3.1415926D+0,1.5707963D+0,6.2831853D+0,
     &2.368705D+3/
      DATA   CMOTP/60.00/, FJX/0.,1./, CNX/.70710678D+0,.70710678D+0/
      DATA   CCN/6.D-7,1.9D-6,-3.4D-6,5.1D-6,-2.52D-5,0.,-9.06D-5,-
     &9.01D-5,0.,-9.765D-4,.0110486D+0,-.0110485D+0,0.,-.3926991D+0,
     &1.6D-6,-3.2D-6,1.17D-5,-2.4D-6,3.46D-5,3.38D-5,5.D-7,2.452D-4,-
     &1.3813D-3,1.3811D-3,-6.25001D-2,-1.D-7,.7071068D+0,.7071068D+0/
      TH( D)=((((( CC1* D+ CC2)* D+ CC3)* D+ CC4)* D+ CC5)* D+ CC6)* D+
     & CC7
      PH( D)=((((( CC8* D+ CC9)* D+ CC10)* D+ CC11)* D+ CC12)* D+ CC13)
     &* D+ CC14
      F( D)= SQRT( POT/ D)* EXP(- CN* D+ TH(-8./ X))
      G( D)= EXP( CN* D+ TH(8./ X))/ SQRT( TP* D)
      X= SQRT( TPCMU* SIGL)* ROLAM
      IF( X.GT.110.) GOTO 2
      IF( X.GT.8.) GOTO 1
      Y= X/8.
      Y= Y* Y
      S= Y* Y
      BER=((((((-9.01D-6* S+1.22552D-3)* S-.08349609D+0)* S+
     &2.6419140D+0)* S-32.363456D+0)* S+113.77778D+0)* S-64.)* S+1.
      BEI=((((((1.1346D-4* S-.01103667D+0)* S+.52185615D+0)* S-
     &10.567658D+0)* S+72.817777D+0)* S-113.77778D+0)* S+16.)* Y
      BR1= CMPLX( BER, BEI)
      BER=(((((((-3.94D-6* S+4.5957D-4)* S-.02609253D+0)* S+
     &.66047849D+0)* S-6.0681481D+0)* S+14.222222D+0)* S-4.)* Y)* X
      BEI=((((((4.609D-5* S-3.79386D-3)* S+.14677204D+0)* S-
     &2.3116751D+0)* S+11.377778D+0)* S-10.666667D+0)* S+.5)* X
      BR2= CMPLX( BER, BEI)
      BR1= BR1/ BR2
      GOTO 3
    1 BR2= FJ* F( X)/ PI
      BR1= G( X)+ BR2
      BR2= G( X)* PH(8./ X)- BR2* PH(-8./ X)
      BR1= BR1/ BR2
      GOTO 3
    2 BR1= CMPLX(.70710678D+0,-.70710678D+0)
    3 ZINT= FJ* SQRT( CMOTP/ SIGL)* BR1/ ROLAM
      RETURN
      END

      SUBROUTINE STR0PC( STRING, STRING1)
      CHARACTER *(*)  STRING, STRING1
      INTEGER*4  I, J, IC
      DO 150, I=1, LEN( STRING)
      IC= ICHAR( STRING( I: I))
      IF( IC.GE.97.AND. IC.LE.122) IC= IC-32
      STRING1( I: I)= CHAR( IC)
  150 CONTINUE
      RETURN
      END